Plugin Store

Copy Sources Between Projects.fh_lua

--[[
@Title: Copy Sources Between Projects
@Type: Standard
@Author: Mark Draper
@Version: 1.0 
@LastUpdated: 2 Oct 2024
@Licence: This plugin is copyright (c) 2024 Mark Draper, and is licensed under the MIT License
which is hereby incorporated by reference (see https://pluginstore.family-historian.co.uk/fh-plugin-licence)
@Description: Saves user-selected Source Records to an external file, along with all linked records such as
Media, Repository, Note/Research Notes and FH7 Source Templates. Imports this file into a different project.
]]

fhInitialise(5, 0, 0, 'save_recommended')
require('luacom')
require('iuplua')
iup.SetGlobal('CUSTOMQUITMESSAGE','YES')
iup.SetGlobal('UTF8MODE', 'YES')
iup.SetGlobal('UTF8MODE_FILE', 'YES')

FSO = luacom.CreateObject('Scripting.FileSystemObject')

function main()

	local option = iup.Alarm(fhGetContextInfo('CI_PLUGIN_NAME'), 'Select action', 'Export Sources',
			'Import Sources', 'Close Plugin')
	if option == 1 then
		ExportSources()
	elseif option == 2 then
		ImportSources()
	end
end

--**********************************************************************************************************--

function ExportSources()

	local tblS = fhPromptUserForRecordSel('SOUR')
	local SourceCount = #tblS
	if SourceCount == 0 then return end

	-- get any dependent records (Media, Repository, etc)

	for _, pS in ipairs(tblS) do
		GetDependentRecords(pS, tblS)
	end

	-- add unique records to new table

	local tblRecords = {}
	local tblDic = {}
	for _, Record in ipairs(tblS) do
		local RecordID = fhGetTag(Record) .. fhGetRecordId(Record)
		if not tblDic[RecordID] then
			table.insert(tblRecords, Record)
			tblDic[RecordID] = true
		end
	end

	-- copy record data into XML table

	local tblT, tblWarnings = GetRecordData(tblRecords)
	SaveFile(tblT, SourceCount, #tblRecords - SourceCount)
	if tblWarnings.RecordLinks then
		local msg = 'Warning: Record links in Rich Text Notes will be imported as plain text.'
		MessageBox(msg, 'OK', 'WARNING')
	end
end

--**********************************************************************************************************--

function GetDependentRecords(pS, tblS)

	-- add second table to break circular references

	local tblDic = {}
	for _, pS in ipairs(tblS) do
		tblDic[fhGetTag(pS) .. fhGetRecordId(pS)] = true
	end

	local p = fhNewItemPtr()
	p:MoveToFirstChildItem(pS)
	while p:IsNotNull() do
		if fhGetValueType(p) == 'link' then
			local pL = fhGetValueAsLink(p)
			if not tblDic[fhGetTag(pL) .. fhGetRecordId(pL)] then
				table.insert(tblS, pL:Clone())
				GetDependentRecords(p, tblS)
			end
		end
		p:MoveNext()
	end
end

--**********************************************************************************************************--

function GetRecordData(tblRecords)

	local tblT = {}				-- data for exported records
	local tblWarnings = {}		-- warning messages

	table.insert(tblT, '')
	table.insert(tblT, '')
	table.insert(tblT, '' .. fhGetAppVersion() .. '')
	table.insert(tblT, '' .. fhGetContextInfo('CI_PROJECT_FILE') .. '')
	table.insert(tblT, '' .. fhGetContextInfo('CI_PROJECT_DATA_FOLDER') .. '')

	for _, Record in ipairs(tblRecords) do
		local tblFields = {}
		table.insert(tblT, '')
		table.insert(tblT, WriteXML('RecordType', fhGetTag(Record)))
		table.insert(tblT, WriteXML('ID', fhGetRecordId(Record)))
		GetChildItemData(Record, tblT, 1, tblWarnings)
		table.insert(tblT, '')
	end
	table.insert(tblT, '\n')

	return tblT, tblWarnings
end

--**********************************************************************************************************--

function GetChildItemData(pItem, tblT, level, tblWarnings)

	local p = fhNewItemPtr()
	p:MoveToFirstChildItem(pItem)
	while p:IsNotNull() do
		local Tag = fhGetTag(p)
		if Tag == '_LKID' or Tag:match('^_LINK_%u$') then			-- convert Record links to plain text
			tblWarnings.RecordLinks = true
		elseif Tag ~= '_FMT' then
			if Tag == '_FIELD' then Tag = fhGetMetafieldShortcut(p) end
			local type = fhGetValueType(p)
			local value
			if type == 'text' then
				value = fhGetValueAsText(p)
			elseif type == 'integer' then
				value = fhGetValueAsText(p)
			elseif type == 'richtext' then
				local rt = fhGetValueAsRichText(p)
				value = rt:GetText()
				if value:match('%')
			table.insert(tblT, WriteXML('Tag', Tag))
			if type ~= '' then table.insert(tblT, WriteXML('Type', type)) end
			if value then table.insert(tblT, WriteXML('Value', value)) end
			GetChildItemData(p, tblT, level + 1, tblWarnings)
			table.insert(tblT, '')
		end
		p:MoveNext()
	end
end

--**********************************************************************************************************--

function WriteXML(Tag, Value)

	if not Value then
		Value = ''
		print('Tag ' .. Tag .. ' is null') 
	end

	-- add character escapes as necessary

	if type(Value) == 'string' then
		if Value:match('%&') then Value = Value:gsub('&', '&') end
		if Value:match('%<') then Value = Value:gsub('<', '<') end
		if Value:match('%>') then Value = Value:gsub('>', '>') end
		if Value:match('%"') then Value = Value:gsub('"', '"') end
		if Value:match("%'") then Value = Value:gsub("'", ''') end
 	end

	-- returns a formatted XML line

	local XML = '<' .. Tag ..  '>' .. Value .. ''
	return XML
end

--**********************************************************************************************************--

function ImportSources()

	-- select output file

	local filedlg = iup.filedlg{title = 'Select Import File', dialogtype = 'OPEN',
			extfilter = 'XML Files (*.xml)|*.xml|All Files|*.*|',
			extdefault = 'xml'}
	if fhGetAppVersion() < 7 then filedlg.extdefault = '.xml' end		-- IUP change
	filedlg:popup()
	if filedlg.Status == '-1' then return end
	local File = filedlg.Value

	-- get XML code from file, read into table, and discard header

	local tblXML = {}
	local objTSr = FSO:OpenTextFile(File, 1, false, -1)
	local XML = objTSr:ReadAll()
	objTSr:Close()
	for Line in XML:gmatch('[^\r\n]+') do
		table.insert(tblXML, Line)
	end
	table.remove(tblXML, 1)

	local tblRecords = BuildRecordTable(tblXML)

	if tblRecords.Version ~= fhGetAppVersion() then
		local msg = 'This file originated in Family Historian Version ' .. tblRecords.Version
		MessageBox(msg, 'OK', 'ERROR')
		return
	end
	if tblRecords.ProjectFile == fhGetContextInfo('CI_PROJECT_FILE') then
		local msg = 'Cannot import Source Records back into the same Project.'
		MessageBox(msg, 'OK', 'ERROR')
		return
	end

	-- check for media files in Project folder

	if not CheckMediaFiles(tblRecords) then return end

	-- create new records

	CreateRecords(tblRecords)
end

--**********************************************************************************************************--

function CheckMediaFiles(tblRecords)

	local action
	local tblFiles = {}

	for _, Record in ipairs(tblRecords.OBJE) do
		for _, Item1 in ipairs(Record.Items1) do
			if Record.Type == 'OBJE' and Item1.Tag:match('FILE') and Item1.Value:match('^Media\\') then
				if not action then
					local msg = 'The import Media Record(s) contain file(s) in the original Project Media ' ..
							'folder. Do you want to copy these files to the current Project Media folder?' ..
							'\n\nAny existing files with the same name will not be overwritten, but ' ..
							'undoing plugin updates does not remove these files.'
					action = MessageBox(msg, 'YESNOCANCEL', 'QUESTION')
				end
				table.insert(tblFiles, Item1.Value)
			end
		end
	end

	if action == 3 or action == 'Cancel' then return end

	-- copy files, creating Media subfolders as necessary

	if action == 1 or action == 'OK' then
		for _, File in ipairs(tblFiles) do
			local source = tblRecords.DataFolder .. '\\' .. File
			local tblPath = {}
			local path = FSO:GetParentFolderName(source)
			while path ~= tblRecords.DataFolder do
				table.insert(tblPath, FSO:GetFolder(path).Name)
				path = FSO:GetParentFolderName(path)
			end
			local destpath = fhGetContextInfo('CI_PROJECT_DATA_FOLDER')
			for i = #tblPath, 1, -1 do
				destpath = destpath .. '\\' .. tblPath[i]
				if not FSO:FolderExists(destpath) then
					FSO:CreateFolder(destpath)
				end
			end
			if not FSO:FileExists(fhGetContextInfo('CI_PROJECT_DATA_FOLDER') .. '\\' .. File) then
				FSO:CopyFile(source, destpath .. '\\')
			end
		end
	end
	return true
end

--**********************************************************************************************************--

function BuildRecordTable(tblXML)

	-- convert table containing raw XML data to formatted table of new records

	local tblRecords = {SOUR = {}, OBJE = {}, REPO = {}, NOTE = {}, ['_SRCT'] = {}, ['_RNOT'] = {}}
	local tblRecord = {}
	local tblItem = {}
	local tblData = {}
	local ActiveTag
	local tblActiveTag = {}

	for i, Line in ipairs(tblXML) do
		local XMLTag, DataLine, EndTag = ParseXML(Line)
		if XMLTag then
			ActiveTag = XMLTag
			table.insert(tblActiveTag, ActiveTag)
			tblData = {}								-- clear current data item
			if XMLTag == '' then				-- start of new record definition
				tblRecord = {}
			elseif XMLTag == '' then				-- start of new first level item
				tblItem[1] = {}
				if not tblRecord.Items1 then tblRecord.Items1 = {} end
			elseif XMLTag == '' then				-- start of new second level item
				tblItem[2] = {}
				if not tblItem[1].Items2 then tblItem[1].Items2 = {} end
			elseif XMLTag == '' then				-- start of new third level item
				tblItem[3] = {}
				if not tblItem[2].Items3 then tblItem[2].Items3 = {} end
			end
		end

		if XMLTag == '' then
			local _ = true
		end

		if DataLine then
			table.insert(tblData, DataLine)
		end
		if EndTag then
			if ActiveTag:match('%w+') ~= EndTag:match('%w+') then
				msg = 'Mismatched XML tags at line ' .. i .. ' (' .. ActiveTag .. ' - ' .. EndTag .. ')'
				MessageBox(msg, 'OK', 'ERROR')
				return
			end
			local Data = table.concat(tblData, '\n')
			if Data == '' then Data = nil end

			-- store data item

			if EndTag == '' then
				tblRecords.Version = tonumber(Data)
			elseif EndTag == '' then
				tblRecords.ProjectFile = Data
			elseif EndTag == '' then
				tblRecords.DataFolder = Data
			elseif EndTag == '' then
				tblRecord.Type = Data
			elseif EndTag == '' then
				tblRecord.ID = tonumber(Data)
			elseif EndTag == '' then
				local level = tblActiveTag[#tblActiveTag - 1]
				level = tonumber(level:match('%d'))
				if level then 
					tblItem[level].Tag = Data					
				end
			elseif EndTag == '' then
				local level = tblActiveTag[#tblActiveTag - 1]
				level = tonumber(level:match('%d'))
				if level then 
					tblItem[level].Type = Data					
				end
			elseif EndTag == '' then
				local level = tblActiveTag[#tblActiveTag - 1]
				level = tonumber(level:match('%d'))
				if level then 
					tblItem[level].Value = Data					
				end
			elseif EndTag == '' then
				table.insert(tblRecord.Items1, tblItem[1])
			elseif EndTag == '' then
				table.insert(tblItem[1].Items2, tblItem[2])
			elseif EndTag == '' then
				table.insert(tblRecord.Items1.Items2.Items3, tblItem[3])
			elseif EndTag == '' then
				table.insert(tblRecords[tblRecord.Type], tblRecord)
			end

			-- remove active tag now data has been processed

			table.remove(tblActiveTag)
			ActiveTag = tblActiveTag[#tblActiveTag]
		end
	end
	return tblRecords
end

--**********************************************************************************************************--

function ParseXML(Line)

	-- split line into tags and data

	local XMLTag = Line:match('^(%<%w+%>)')
	if XMLTag then Line = Line:gsub(XMLTag, '') end
	local EndTag = Line:match('(%<%/%w+%>)$')
	if EndTag then Line = Line:gsub(EndTag, '') end
	local Data = Line

	if Data:match('%&%;') then Data = Data:gsub('&', '&') end
	if Data:match('%<%;') then Data = Data:gsub('%<%;', '<') end
	if Data:match('%>%;') then Data = Data:gsub('%>%;', '>') end
	if Data:match('%"%;') then Data = Data:gsub('%"%;', '"') end
	if Data:match('%&apos%;') then Data = Data:gsub('&apos%;', "'") end
	if Data == '' then Data = nil end
 
	return XMLTag, Data, EndTag
end

--**********************************************************************************************************--

function CreateRecords(tblRecords)

	local tblXref = {}
	local tblRecordLinks = {}
	local function CreateRecord(Record, tblXref, tblRecordLinks, MakeLinks)
		local RecordType = Record.Type
		local OldID = Record.ID
		local pNew = fhCreateItem(RecordType)
		StripChildFields(pNew)
		if not tblXref[RecordType] then
			tblXref[RecordType] = {}
		end
		tblXref[RecordType][OldID] = fhGetRecordId(fhGetItemPtr(pNew))

		-- create links now if set

		if MakeLinks then
			for _, Item in ipairs(Record.Items1) do
				if Item.Type == 'link' and Item.Tag == '_SRCT' then
					local pL = fhCreateItem(Item.Tag, pNew)
					local pT = fhNewItemPtr()
					local NewID = tblXref[Item.Tag][tonumber(Item.Value)]
					pT:MoveToRecordById(Item.Tag, NewID)
					fhSetValueAsLink(pL, pT)
				end
			end
		end

		-- create required subfields (except template links, which have already been created

		for k, Item in pairs(Record.Items1) do
			if Item.Tag ~= '_SRCT' then					
				local p = fhCreateItem(Item.Tag, pNew)
				if p:IsNotNull() then
					StripChildFields(p)
					if Item.Type == 'link' then
						tblRecordLinks[p:Clone()] = Item.Tag .. Item.Value
					else
						SetItemValue(p, Item)
					end
					if Item.Items2 then							-- next level children
						for kk, ChildItem in pairs(Item.Items2) do
							local q = fhCreateItem(ChildItem.Tag, p)
							if q:IsNotNull() then
								StripChildFields(q)
								SetItemValue(q, ChildItem)
								if ChildItem.Type == 'link' then
									tblRecordLinks[q:Clone()] = ChildItem.Tag .. ChildItem.Value
								end
							else
								print(ChildItem.Tag)
							end
						end
					end
				else
					print(Item.Tag)
				end
			end
		end
	end

	-- create Source Templates first

	for _, Record in ipairs(tblRecords['_SRCT']) do
		CreateRecord(Record, tblXref, tblRecordLinks)
	end

	-- create Sources

	for _, Record in ipairs(tblRecords.SOUR) do
		CreateRecord(Record, tblXref, tblRecordLinks, true)
	end

	-- create Media, Repository and Note records

	for _, Record in ipairs(tblRecords.OBJE) do
		CreateRecord(Record, tblXref, tblRecordLinks)
	end

	for _, Record in ipairs(tblRecords.REPO) do
		CreateRecord(Record, tblXref, tblRecordLinks)
	end

	for _, Record in ipairs(tblRecords.NOTE) do
		CreateRecord(Record, tblXref, tblRecordLinks)
	end

	-- make links between records now all created

	for pL, TypeOldID in pairs(tblRecordLinks) do
		local p = fhNewItemPtr()
		local RecordType = TypeOldID:match('%D+')
		local OldID = tonumber(TypeOldID:match('%d+'))
		local NewID = tblXref[RecordType][OldID]
		p:MoveToRecordById(RecordType, NewID)
		fhSetValueAsLink(pL, p)
	end

	local N1 = #tblRecords.SOUR
	local N2 = #tblRecords.REPO + #tblRecords.NOTE + #tblRecords['_RNOT'] + #tblRecords.OBJE
			+ #tblRecords['_SRCT']
	local msg = N1 .. ' Source Records and ' .. N2 .. ' linked Records imported from file'
	MessageBox(msg, 'OK', 'INFORMATION')
end

--**********************************************************************************************************--

function StripChildFields(pParent)

	-- removes all child items from passed item pointer

	local tblX = {}
	local p = fhNewItemPtr()
	p:MoveToFirstChildItem(pParent)
	while p:IsNotNull() do
		table.insert(tblX, p:Clone())
		p:MoveNext()
	end
	for _, pX in ipairs (tblX) do fhDeleteItem(pX) end
end

--**********************************************************************************************************--

function SetItemValue(p, Item)

	-- excludes links

	if Item.Type == 'richtext' then
		local rt = fhNewRichText()
		rt:SetText(Item.Value)
		fhSetValueAsRichText(p, rt)
	elseif Item.Type == 'date' then
		local dt = fhNewDate()
		dt:SetValueAsText(Item.Value)
		fhSetValueAsDate(p, dt)
	else
		fhSetValueAsText(p, Item.Value or '')
	end
end

--**********************************************************************************************************--

function SaveFile(tblT, N1, N2)

	-- select output file

	local filedlg = iup.filedlg{title = 'Select Export File', dialogtype = 'SAVE',
			extfilter = 'XML Files (*.xml)|*.xml|All Files|*.*|'}
	filedlg:popup()
	if filedlg.Status == '-1' then return end
	local File = filedlg.Value
	if FSO:GetExtensionName(File) == '' then File = File .. '.xml' end	-- add default extension if missing

	-- write XML code to file (delete any existing file automatically, as overwrite has issues in WINE)

	if FSO:FileExists(File) then FSO:DeleteFile(File) end
	local objTSw = FSO:CreateTextFile(File, true, true)
	objTSw:Write(table.concat(tblT, '\n'))
	objTSw:Close()

	MessageBox(N1 .. ' Source Records and ' .. N2 .. ' linked Records exported to file', 'OK', 'INFORMATION')
end

--**********************************************************************************************************--

function MessageBox(Message, Buttons, Icon, Title, Default)

	-- replaces built-in function with custom version containing more options

	if fhGetAppVersion() < 7 and Buttons == 'YESNOCANCEL' then		-- not supported for iup.messagedlg in FH6
		return fhMessageBox(Message, 'MB_YESNOCANCEL', 'MB_QUESTION')
	end

	local msgdlg = iup.messagedlg{value = Message, buttons = Buttons, dialogtype = Icon,
			title = Title or fhGetContextInfo('CI_PLUGIN_NAME'), buttondefault = Default}
	msgdlg:popup()
	return tonumber(msgdlg.ButtonResponse)
end

--**********************************************************************************************************--

main()

Source:Copy-Sources-Between-Projects.fh_lua