home *** CD-ROM | disk | FTP | other *** search
/ The AGA Experience 2 / agavol2.iso / rexx / gedcom2scion.rexx < prev    next >
OS/2 REXX Batch file  |  1995-10-05  |  31KB  |  1,023 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  *                                                                          *
  4.  * $VER: GEDCOM2Scion.rexx 2.14 (14 Sep 1995)
  5.  *                                                                          *
  6.  *                      Written by Freddy Ariës                             *
  7.  *                                                                          *
  8.  * This program was created to import GEDCOM data into the Scion database.  *
  9.  * It should work pretty good by now, although no guarantees whatsoever     *
  10.  * are made. If you have problems using this script, please contact me, and *
  11.  * describe exactly what the problem is, or better yet, send me a copy of   *
  12.  * the GEDCOM file you are trying to read), and I will try to fix it.       *
  13.  *                                                                          *
  14.  * GEDCOM was developed by the Family History Department of the Church of   *
  15.  * Jesus Christ of Latter-day Saints to provide a flexible uniform format   *
  16.  * for exchanging computerized genealogical data.  GEDCOM is an acronym for *
  17.  * GEnealogical Data Communication.  GEDCOM is provided to foster the       *
  18.  * sharing of genealogical information and the development of a wide range  *
  19.  * of inter-operable software products to assist genealogists, historians,  *
  20.  * and other researchers.                                                   *
  21.  *                                                                          *
  22.  * This script uses (by default) the rexxreqtools.library (which requires   *
  23.  * a version of reqtools larger than 2.0 and rexxsyslib.library).           *
  24.  * If you do not have these, you need to supply the NOREQ argument (for     *
  25.  * Shell output), or the QUIET argument (for no output at all).             *
  26.  *                                                                          *
  27.  * Even though this script does no parsing of dates, it's safer if they     *
  28.  * are in the exact format "DD MMM YYYY".                                   *
  29.  * The database must be running for this AREXX script to work.              *
  30.  *                                                                          *
  31.  * Now with progress indicator, using rexxarplib.library (requested by      *
  32.  * Robbie J. Akins himself).                                                *
  33.  *                                                                          *
  34.  * All unrecognized fields or fields that Scion doesn't use, are skipped.   *
  35.  * NOTE: The program generates a file DATABASE.log (where DATABASE is the   *
  36.  *  name of the GEDCOM file read), in the directory where the GEDCOM file   *
  37.  *  is located. This .log file contains parsing info about which lines were *
  38.  *  skipped and which non-fatal errors were encountered. It may be a good   *
  39.  *  idea to read this file!                                                 *
  40.  *  FAMS and FAMC fields, and EVEN structures will always be skipped,       *
  41.  *  because I use another method of establishing family (spouse & children) *
  42.  *  relationships. If no relationships are established, this probably means *
  43.  *  that the imported file does not support that other method. If you       *
  44.  *  encounter such a file, please send it to me, and tell me what program   *
  45.  *  generated it. If this happens a lot, I will add support for the parsing *
  46.  *  of these relations in a future version.                                 *
  47.  *                                                                          *
  48.  * TO DO (but low priority, unless someone really wants this [?]):          *
  49.  *  - optional processing of long comments into external note files         *
  50.  *  - Add support for other character formats (like the ANSEL format that   *
  51.  *    is described in the GEDCOM specification)                             *
  52.  *  - Find a method to handle dates with more than 12 characters            *
  53.  *  - Add support for EVEN(t) structures                                    *
  54.  *  - More intelligent way of recognizing/parsing family data.              *
  55.  *  - I'm thinking of a way to allow modifying an existing database. The    *
  56.  *    current version will only add to a database, and doesn't care for     *
  57.  *    double entries. This could get complicated though, so maybe it'll     *
  58.  *    never come.                                                           *
  59.  *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
  60.  *                                                                          *
  61.  ****************************************************************************/
  62.  
  63. options failat 20; options results
  64. arg inname inval
  65.  
  66. versionstr = "2.14"
  67. lnum = 0; outp = 1; output = stdout
  68. usereq = 1; /* change this to 0 if you don't want to use reqtools */
  69. prgrs = 1; pgopen = 0; /* use RexxArp progress indicator */
  70.   /* change prgrs to 0 for not using it */
  71. NL = '0A'x
  72.  
  73. signal on IOERR
  74.  
  75. /* parse command line options, to enable calling the script automatically,
  76.  * eg. from a function key
  77.  */
  78.  
  79. do while inname = '?'
  80.   writeln(stdout, "INFILE/A,QUIET/S,NOREQ/S ")
  81.   pull inname inval
  82. end
  83.  
  84. if inname ~= "" then do
  85.   if inname = "QUIET" | inname = "NOREQ" then do
  86.     inval = inname; inname = ""
  87.   end
  88. end
  89.  
  90. if inval = "QUIET" then do
  91.   outp = 0; usereq = 0
  92. end
  93. else if inval = "NOREQ" then usereq = 0
  94.  
  95. if usereq & ~show('l','rexxreqtools.library') then do
  96.   if exists('libs:rexxreqtools.library') then
  97.     call addlib('rexxreqtools.library',0,-30,0)
  98.   else do
  99.     usereq = 0; outp = 1
  100.     Tell("Unable to open rexxreqtools.library - using text output")
  101.   end
  102. end
  103.  
  104. if ~usereq then prgrs = 0
  105.  
  106. if prgrs & ~show('l','rexxarplib.library') then do
  107.   if exists('libs:rexxarplib.library') then
  108.     call addlib('rexxarplib.library',0,-30,0)
  109.   else
  110.     prgrs = 0
  111. end
  112.  
  113. /* These first few lines are stolen from Peter Billings - thanks Peter ;-) */
  114. if ~show('P','SCIONGEN') then do
  115.   TermError('I am sorry to say that the SCION Genealogist' || NL ||,
  116.     'database is not available. Please start the' || NL ||,
  117.     'SCION program BEFORE using this script!')
  118. end
  119.  
  120. myport = "SCIONGEN"
  121. address value myport
  122. GETDBNAME
  123. dbname = upper(RESULT)
  124.  
  125. if outp & ~usereq then do
  126.   Tell("GEDCOM to Scion conversion script v"||versionstr||" by Freddy Ariës")
  127.   Tell("Scion (output) database: "||dbname)
  128. end
  129.  
  130. if inname = "" then do
  131.   /* ignore the value of outp; if we can't ask for the input file,
  132.    * we can't do anything!
  133.    */
  134.   if usereq then do
  135.     /* We need a file requester for further data */
  136.     inname = rtfilerequest(,,'GEDCOM Input File',,'rtfi_buffer = true   rt_pubscrname = SCIONGEN   rtfi_initialpath = RAM:',)
  137.   end
  138.   else do
  139.     Tell("Please enter the filename (with complete path) of the GEDCOM file:")
  140.     TellNN("Input file: ")
  141.     pull inname
  142.   end    
  143.   if inname = '' then
  144.     TermError("ERROR: No Input File!")
  145. end
  146.   
  147. if ~open(infile, inname, "r") then
  148.   TermError("ERROR: Input file '"inname"' not found!")
  149.  
  150. if ~usereq then
  151.   Tell("Be patient - this may take a while...")
  152.  
  153. /* Initialize line count, individual counter and family counter */
  154. ink = GetNextLine()
  155. if left(ink, 6) ~= "0 HEAD" then do
  156.   close(infile)
  157.   TermError("ERROR: Invalid beginning of file - not a valid GEDCOM format")
  158. end
  159.  
  160. lvlstr = '0'; lvl = 1; atlvl = 1
  161. IRNArr.0 = ''; IRNArr.1 = ''; FGRNArr.0 = ''; FGRNArr.1 = ''
  162.  
  163. /* Read the "HEAD" section until we find something else of level "0" */
  164.  
  165. prstot = ""
  166. ink = ParseHeader(atlvl)
  167. GETPROGVERSION
  168. prsr = RESULT
  169. prsr = "Destination:   Scion Genealogist "||prsr
  170. if ~usereq then
  171.   Tell(prsr)
  172. else
  173.   prstot = prstot||prsr||NL
  174. prsr = "Dest. file:    "||dbname
  175. if ~usereq then
  176.   Tell(prsr)
  177. else do
  178.   prstot=prstot||prsr||NL||NL||"Parsing will take a while - be patient."||,
  179.     NL||"Click `Continue' to start parsing..."
  180.   rv = rtezrequest(prstot,'_Continue| _Abort ','Converter Message:','rt_pubscrname = SCIONGEN')
  181.   if rv = 0 then EXIT
  182. end
  183.  
  184. /* TO DO: if inname ends on .GED, strip the extension */
  185. if ~open(errfile, inname||".log", "w") then
  186.   errfile = stdout
  187.  
  188. /* Now scan the following level "0" fields for individuals;
  189.  * skip the families, for the moment
  190.  */
  191.  
  192. irn = 0
  193.  
  194. if prgrs then do
  195.   Postmsg(10, 10, "GEDCOM to Scion (by Freddy Ariës)\Database: "||,
  196.     StripPath(inname)||"\Persons parsed: "||irn||"\", "SCIONGEN")
  197.   pgopen = 1
  198. end
  199.  
  200. replay = 0
  201. do while ~eof(infile)
  202.   lvlstr = word(ink, 1)
  203.   lvl = GetNumType(lvlstr)
  204.  
  205.   if lvl = atlvl then do
  206.     tagstr = upper(word(ink, words(ink)))
  207.     if tagstr = "INDI" then do
  208.       nstr = compress(word(ink, 2), '@ ')
  209.       tp = GGetIRN(nstr)
  210.       if tp ~= 0 then
  211.         writeln(errfile, "ERROR: Duplicate person encountered: "||nstr||" (IRN "||tp||") (line: "||lnum||")")
  212.       irn = irn + 1
  213.     if pgopen then Postmsg(,, "\\Persons parsed: "||irn||"\", "SCIONGEN")
  214.       ink = ParsePerson(nstr, lvl)
  215.       if ink ~= "" then replay = 1
  216.     end
  217.   end
  218.   /* Skip all lines with level ~= current level (0) */
  219.   if replay = 0 then ink = GetNextLine()
  220.   else replay = 0
  221. end
  222.  
  223. if ~usereq then do
  224.   Tell("Number of persons parsed: "||irn)
  225.   GETTOTALIRN
  226.   tot = RESULT
  227.  
  228. /* optional, as extra check:
  229.   Tell("Total number of persons in the Scion database: "||tot)
  230.  */
  231. end
  232.  
  233. /* Now rescan the entire file for families; I know it is quite
  234.  * inefficient this way, but it's better to add all the persons first,
  235.  * and then establish the relations...
  236.  */
  237.  
  238. close(infile)
  239. if ~open(infile, inname, "r") then
  240.   TermError("ERROR: Unable to read relations!")
  241.  
  242. if ~usereq then
  243.   Tell("Scanning file again to establish relations...")
  244.  
  245. lvlstr = '0'; lvl = 1; atlvl = 1
  246. fgrn = 0; lnum = 0; fxs = 0; finp = 0; ffile = 0
  247.  
  248. if pgopen then Postmsg(,, "\\\Families parsed: "||fgrn, "SCIONGEN")
  249.  
  250. replay = 0
  251. do while ~eof(infile)
  252.   if replay = 0 then ink = GetNextLine()
  253.   else replay = 0
  254.  
  255.   lvlstr = word(ink, 1)
  256.   lvl = GetNumType(lvlstr)
  257.  
  258.   if lvl = atlvl then do
  259.     tagstr = upper(word(ink, words(ink)))
  260.     if tagstr = "FAM" then do
  261.       nstr = compress(word(ink, 2),'@ ')
  262.       fp = GGetFGRN(nstr)
  263.       if fp ~= 0 then
  264.         writeln(errfile, "WARNING: Duplicate family encountered: "||nstr||" (FGRN "||fp||") (line: "||lnum||")")
  265.         /* TO DO: is the error message necessary? Or can we simply go on? */
  266.       else
  267.         fgrn = fgrn + 1
  268.     if pgopen then Postmsg(,, "\\\Families parsed: "||fgrn, "SCIONGEN")
  269.       ink = ParseFamily(nstr, lvl)
  270.       if ink ~= "" then replay = 1
  271.     end
  272.     else if tagstr = "TRLR" then do
  273.       close(infile)
  274.       if pgopen then do
  275.         Postmsg()
  276.         pgopen = 0
  277.       end
  278.       GETTOTALFGRN
  279.       ftot = RESULT
  280.       if usereq then do
  281.     GETTOTALIRN
  282.     itot = RESULT
  283.         TermError("PARSING DONE:"||NL||"Number of persons parsed: "||irn||,
  284.           NL||"Number of families parsed: "||fgrn||,
  285.       NL||NL||"DON'T FORGET TO SAVE YOUR SCION FILE!!!")
  286.  
  287. /* optional, as extra check:
  288.       NL||"Total number of persons in the Scion database: "||itot||,
  289.       NL||"Total number of families in the Scion database: "||ftot||,
  290.  */
  291.  
  292.       end
  293.       else do
  294.     Tell("Number of families parsed: "||fgrn)
  295.         TermError("DONE! DON'T FORGET TO SAVE YOUR SCION FILE!!!")
  296.  
  297. /* optional, as extra check:
  298.     Tell("Total number of families in the Scion database: "||ftot)
  299.  */
  300.       end
  301.     end
  302.   end
  303.   /* Skip all the fields at lvl ~= this level */
  304. end
  305. close(infile)
  306. if ink ~= "0 TRLR" then
  307.   TermError("ERROR: Unexpected end of file")
  308. else
  309.   TermError("ERROR: Trailer not recognized! (line: "||lnum||")")
  310.  
  311. ParseHeader: PROCEDURE EXPOSE infile prstot NL outp usereq lnum
  312. parse arg inilvl
  313. do while ~eof(infile)
  314.   ins = GetNextLine()
  315.   if ins = "" then
  316.     TermError("ERROR: Unexpected end of file")
  317.   lvlstr = word(ins, 1)
  318.   lvl = GetNumType(lvlstr)
  319.   if lvl <= inilvl then RETURN ins
  320.   if lvl = inilvl+1 then do
  321.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  322.     curr = upper(word(lstr, 1))
  323.     if curr = "SOUR" then do
  324.       lstr = strip(delstr(lstr, 1, length(curr)))
  325.       prsr = "Source system: "||lstr
  326.       if ~usereq then
  327.     Tell(prsr)
  328.       else
  329.         prstot = prstot||prsr||NL
  330.       ins = ParseSource(lvl)
  331.       lvlstr = word(ins, 1)
  332.       lvl = lvlstr + 1
  333.       if lvl <= inilvl then RETURN ins
  334.       if lvl = inilvl+1 then do
  335.         lstr = strip(delstr(ins, 1, length(lvlstr)))
  336.         curr = upper(word(lstr, 1))
  337.       end
  338.       else TermError("ERROR: This should never happen [1] (line: "||lnum||")")
  339.     end
  340.     if curr = "DATE" then do
  341.       lstr = strip(delstr(lstr, 1, length(curr)))
  342.       prsr = "Creation date: "||lstr
  343.       if ~usereq then
  344.     Tell(prsr)
  345.       else
  346.         prstot = prstot||prsr||NL
  347.     end
  348.     else if curr = "FILE" then do
  349.       lstr = strip(delstr(lstr, 1, length(curr)))
  350.       prsr = "Source file:   "||lstr
  351.       if ~usereq then
  352.     Tell(prsr)
  353.       else
  354.         prstot = prstot||prsr||NL
  355.     end
  356.     /* add COPR (copyright) and GEDC VERS parsing
  357.      */
  358.   end
  359. end
  360. TermError("ERROR: Unexpected end of file")
  361.  
  362. ParseSource: PROCEDURE EXPOSE infile prstot NL outp usereq lnum
  363. parse arg namlvl
  364. /* Scan for "NAME" and "VERS" */
  365. do while ~eof(infile)
  366.   ins = GetNextLine()
  367.   if ins = "" then
  368.     TermError("ERROR: Unexpected end of file")
  369.   lvlstr = word(ins, 1)
  370.   lvl = GetNumType(lvlstr)
  371.   if lvl <= namlvl then RETURN ins
  372.   if lvl = namlvl+1 then do
  373.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  374.     curr = upper(word(lstr, 1))
  375.     if curr = "VERS" then do
  376.       lstr = strip(delstr(lstr, 1, length(curr)))
  377.       prsr = "Version:       "||lstr
  378.       if ~usereq then
  379.         Tell(prsr)
  380.       else
  381.         prstot = prstot||prsr||NL
  382.     end
  383.     else if curr = "NAME" then do
  384.       lstr = strip(delstr(lstr, 1, length(curr)))
  385.       prsr = "Created by:    "||lstr
  386.       if ~usereq then
  387.         Tell(prsr)
  388.       else
  389.         prstot = prstot||prsr||NL
  390.     end
  391.   end
  392. end
  393. TermError("ERROR: Unexpected end of file")
  394.  
  395. ParsePerson: PROCEDURE EXPOSE infile IrnArr. errfile outp usereq lnum
  396. parse arg pnum, inilvl
  397. replay = 0
  398. prn = GetNewPerson()
  399. IRNArr.0 = IRNArr.0||pnum||' '
  400. IRNArr.1 = IRNArr.1||prn||' '
  401. do while ~eof(infile)
  402.   if replay = 0 then ins = GetNextLine()
  403.   else replay = 0
  404.   if ins = "" then
  405.     TermError("ERROR: Unexpected end of file")
  406.  
  407.   lvlstr = word(ins, 1)
  408.   lvl = GetNumType(lvlstr)
  409.   if lvl <= inilvl then RETURN ins
  410.   if lvl = inilvl + 1 then do
  411.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  412.     curr = upper(word(lstr, 1))
  413.   end
  414.  
  415.   if curr = "NAME" then StorePersName(strip(delstr(lstr, 1, length(curr))), prn)
  416.   else if curr = "SEX" then StorePersSex(strip(delstr(lstr, 1, length(curr))), prn)
  417.   else if curr = "BIRT" | curr = "DEAT" | curr = "BURI" then do
  418.     ins = ParsePersDatePlace(curr, prn, lvl)
  419.     replay = 1    
  420.   end
  421.   else if curr = "CHR" | curr = "BAPM" | curr = "BAPL" | curr = "CHRA" | curr = "CONF" then
  422.   do
  423.     /* only here because it made the 'BIRT' line too long :-( */
  424.     ins = ParsePersDatePlace(curr, prn, lvl)
  425.     replay = 1    
  426.   end
  427.   else if curr = "OCCU" then StoreOccup(strip(delstr(lstr, 1, length(curr))), prn)
  428.   else if curr = "EDUC" then StoreEduc(strip(delstr(lstr, 1, length(curr))), prn)
  429.   else if curr = "RELI" then StoreRelig(strip(delstr(lstr, 1, length(curr))), prn)
  430.   else if curr = "STIL" then StoreCOD("stillborn", prn)
  431.     /* Note: 'STIL' is not part of the official GEDCOM standard */
  432.   else if curr = "NOTE" then do
  433.     ins = StorePersComment(strip(delstr(lstr, 1, length(curr))), prn, lvl)
  434.     replay = 1
  435.   end
  436.   else if curr = "FAMC" | curr = "FAMS" | curr = "NUMB" then do
  437.     /* nothing - children and spouse relationships are established later
  438.      * and NUMB fields are considered to be irrelevant
  439.      * Note: we do not output a "Skipped" message for these fields.
  440.      */
  441.   end
  442.   else if curr = "CHAN" then do
  443.     ins = SkipChanged(lvl)
  444.     replay = 1
  445.     /* no 'SKIPPED' message for these fields */
  446.   end
  447.   else do
  448.     olv = lvl - 1
  449.     writeln(errfile, "SKIPPED: Level "||olv||" field "||curr||" for person "||prn||"! (line: "||lnum||")")
  450.   end
  451. end
  452. TermError("ERROR: Unexpected end of file")
  453.  
  454. ParseFamily: PROCEDURE EXPOSE infile ffile errfile outp usereq lnum fxs finp FGRNArr. IRNArr.
  455. parse arg fnum, inilvl
  456. replay = 0; fxs = 0; finp = 0; fins = 0
  457.  
  458. /* replay: parse the currently read line, don't read the next one
  459.  * fxs   : family exists; if 0, only allow HUSB and WIFE, rest to tempfile
  460.  *       ~= 0, then contains FGRN (family number)
  461.  * finp  : file input; 0 = from sourcefile (GEDCOM), 1 = from tempfile
  462.  */
  463.  
  464. open(ffile, "T:Scion.GPF", "w")
  465.  
  466. do while (finp = 0 & ~eof(infile)) | (finp = 1 & ~eof(ffile))
  467.   if replay = 0 then ins = GetNextFLine()
  468.   else
  469.     replay = 0
  470.  
  471.   if ins = "" & finp = 0 then
  472.     TermError("ERROR: Unexpected end of file!")
  473.  
  474.   if finp = 1 & eof(ffile) then do
  475.     close(ffile)
  476.     RETURN fins
  477.   end
  478.  
  479.   lvlstr = word(ins, 1)
  480.   lvl = GetNumType(lvlstr)
  481.   if (lvl <= inilvl) & (finp = 0) then do
  482.     finp = 1
  483.     close(ffile)
  484.     if ~open(ffile, "T:Scion.GPF", "r") | eof(ffile) then do
  485.       close(ffile)
  486.       RETURN ins
  487.     end
  488.     fins = ins
  489.     ITERATE
  490.   end
  491.   if lvl = inilvl + 1 then do
  492.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  493.     curr = upper(word(lstr, 1))
  494.   end
  495.  
  496.   if curr = "HUSB" then fxs = StoreFamHusband(compress(delstr(lstr, 1, length(curr)), ' @'), fnum)
  497.   else if curr = "WIFE" then fxs = StoreFamWife(compress(delstr(lstr, 1, length(curr)), ' @'), fnum)
  498.   else if curr = "CHIL" then do
  499.     if lvl > inilvl + 1 then do
  500.       /* TO DO: for now, "ADOP" etc. fields are skipped */
  501.       olv = lvl - 1
  502.       lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
  503.       writeln(errfile, "SKIPPED: Level "||olv||" field "||lostr||" for family "||fnum||"! (line: "||lnum||")")
  504.       ITERATE
  505.     end
  506.     if fxs = 0 then do
  507.       if finp = 1 then
  508.         writeln(errfile, "ERROR: Family for "||lstr||" does not exist!")
  509.       else
  510.         FOutput(ins)
  511.     end
  512.     else StoreFamChild(compress(delstr(lstr, 1, length(curr)), ' @'), fxs)
  513.   end
  514.   else if curr = "MARR" | curr = "DIV" | curr = "ANUL" | curr = "ENGA" then do
  515.     if fxs = 0 then do
  516.       if finp = 1 then
  517.         writeln(errfile, "ERROR: Family for "||lstr||" does not exist!")
  518.       else
  519.         FOutput(ins)
  520.     end
  521.     ins = ParseFamDatePlace(curr, fxs, lvl)
  522.     if ins ~= 0 then
  523.       replay = 1
  524.   end
  525.   else if curr = "NOTE" then do
  526.     if lvl > inilvl + 1 then do
  527.       olv = lvl - 1
  528.       lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
  529.       writeln(errfile, "SKIPPED: Level "||olv||" field "||lostr||" for family "||fnum||"! (line: "||lnum||")")
  530.       ITERATE
  531.     end
  532.     if fxs = 0 then do
  533.       if finp = 1 then
  534.         writeln(errfile, "ERROR: Family for "||lstr||" does not exist!")
  535.       else
  536.         FOutput(ins)
  537.     end
  538.     ins = StoreFamComment(strip(delstr(lstr, 1, length(curr))), fxs, lvl)
  539.     replay = 1
  540.   end
  541.   else if curr = "NUMB" then do
  542.     /* nothing - NUMB fields are irrelevant
  543.      * Note: we do not output a "Skipped" message for these fields.
  544.      */
  545.   end
  546.   else if curr = "CHAN" then do
  547.     ins = SkipChanged(lvl)
  548.     replay = 1
  549.     /* no 'SKIPPED' message for these fields */
  550.   end
  551.   else do
  552.     olv = lvl - 1
  553.     writeln(errfile, "SKIPPED: Level "||olv||" field "||curr||" in family "||fnum||"! (line: "||lnum||")")
  554.   end
  555. end
  556. close(ffile)
  557. if finp = 1 then
  558.   RETURN fins
  559. TermError("ERROR: Unexpected end of file!")
  560.  
  561. GetNumType: PROCEDURE EXPOSE outp infile usereq lnum
  562. parse arg str
  563. if DATATYPE(str) ~= 'NUM' then
  564.   TermError("ERROR: Level indicator expected -> error in GEDCOM specification? String is "||str||" (line: "||lnum||")")
  565. return str + 1
  566.  
  567. GetNextFLine: PROCEDURE EXPOSE infile ffile lnum finp
  568. if finp = 0 then return GetNextLine()
  569. ignl = ""
  570. do while ignl = "" & ~eof(ffile)
  571.   ignl = readln(ffile)
  572.   if ignl ~= "" then ignl = strip(ignl)
  573.   /* so we can check if strip(ignl) is still ~= "" */
  574. end
  575. return ignl
  576.  
  577. GetNextLine: PROCEDURE EXPOSE infile lnum
  578. lnum = lnum + 1
  579. ignl = ""
  580. do while ignl = "" & ~eof(infile)
  581.   ignl = readln(infile)
  582.   if ignl ~= "" then ignl = strip(ignl)
  583.   /* so we can check if strip(ignl) is still ~= "" */
  584. end
  585. return ignl
  586.  
  587. FOutput: PROCEDURE EXPOSE ffile errfile
  588. parse arg iline
  589. if ~exists("T:Scion.GPF") then do
  590.   writeln(errfile, "ERROR: no tempfile for line: "||iline)
  591.   return 0
  592. end
  593. else writeln(ffile, iline)
  594. return 0
  595.  
  596. StorePersName: PROCEDURE
  597. parse arg nstr, pnum
  598. nstr = strip(nstr, 'B', '/')
  599. ps = pos('/', nstr)
  600. if ps = 0 then do
  601.   fname = ""
  602.   lname = nstr
  603. end
  604. else do
  605.   fname = left(nstr, ps-1)
  606.   lname = right(nstr, length(nstr)-ps)
  607. end
  608. PUTLASTNAME pnum lname
  609. PUTFIRSTNAME pnum fname
  610. return 1
  611.  
  612. StorePersSex: PROCEDURE
  613. parse arg nstr, pnum
  614.  sxstr = upper(left(nstr, 1))
  615.  if sxstr ~= 'M' then sxstr = 'F'
  616. PUTSEX pnum sxstr
  617. return 1
  618.  
  619. ParsePersDatePlace: PROCEDURE EXPOSE infile outp usereq lnum
  620. parse arg idstr, pnum, inilvl
  621. datstr = ""
  622. plcstr = ""
  623. causestr = ""
  624. do while ~eof(infile)
  625.   ins = GetNextLine()
  626.   if eof(infile) then
  627.     TermError("ERROR: Unexpected end of file!")
  628.   lvlstr = word(ins, 1)
  629.   lvl = GetNumType(lvlstr)
  630.   if lvl <= inilvl then do
  631.     select
  632.       when idstr = "BIRT" then do
  633.     if datstr ~= "" then
  634.       PUTBIRTHDATE pnum datstr
  635.     if plcstr ~= "" then
  636.       PUTBIRTHPLACE pnum plcstr
  637.       end
  638.       when idstr = "DEAT" then do
  639.     if datstr ~= "" then
  640.       PUTDEATHDATE pnum datstr
  641.     if plcstr ~= "" then
  642.       PUTDEATHPLACE pnum plcstr
  643.     if causestr ~= "" then
  644.       PUTDIEDOF pnum causestr
  645.       end
  646.       when idstr = "BURI" then do
  647.     if datstr ~= "" then
  648.       PUTBURIALDATE pnum datstr
  649.     if plcstr ~= "" then
  650.       PUTBURIALPLACE pnum plcstr
  651.       end
  652.       when idstr = "BAPL" | idstr = "BAPM" | idstr = "CHR" | idstr = "CHRA" | idstr = "CONF" then do
  653.     if datstr ~= "" then
  654.       PUTBAPTISMDATE pnum datstr
  655.     if plcstr ~= "" then
  656.       PUTBAPTISMPLACE pnum plcstr
  657.       end
  658.       otherwise
  659.         /* do nothing */
  660.     end
  661.     RETURN ins
  662.   end
  663.   if lvl = inilvl+1 then do
  664.     lstr = strip(delstr(ins, 1, length(lvlstr)))
  665.     curr = upper(word(lstr, 1))
  666.     if curr = "DATE" then do
  667.       datstr = strip(delstr(lstr, 1, length(curr)))
  668.     end
  669.     else if curr = "PLAC" then do
  670.       plcstr = strip(delstr(lstr, 1, length(curr)))
  671.     end
  672.     else if curr = "QUAY" then do
  673.       lstr = strip(delstr(lstr, 1, length(curr)))
  674.       if DATATYPE(lstr) = 'NUM' & lstr < 2 then do
  675.         if datstr ~= "" then datstr = datstr||'?'
  676.         if plcstr ~= "" then plcstr = plcstr||'?'
  677.       end
  678.     end
  679.     else if curr = "CAUS" then do
  680.       causestr = strip(delstr(lstr, 1, length(curr)))
  681.     end
  682.   end
  683.   /* Skip all fields of lvl > inilvl */
  684. end
  685. return 0
  686.  
  687. ParseFamDatePlace: PROCEDURE EXPOSE infile ffile errfile outp usereq lnum finp FGRNArr.
  688. parse arg idstr, ff, inilvl
  689. datstr = ""; plcstr = ""; clbrnt = ""
  690. do while ~eof(infile) | ~eof(ffile)
  691.   ins = GetNextFLine()
  692.  
  693.   if finp = 0 & ins = "" then
  694.     TermError("ERROR: Unexpected end of file (Parsing Family Events)!")
  695.  
  696.   if finp = 1 & eof(ffile) then do
  697.     if ff ~= 0 then do
  698.       if idstr = "MARR" then do
  699.         if datstr ~= "" then
  700.         PUTMARRYDATE ff datstr
  701.         if plcstr ~= "" then
  702.         PUTMARRYPLACE ff plcstr
  703.         if clbrnt ~= "" then
  704.           PUTCELEBRANT ff clbrnt
  705.       end
  706.       else if idstr = "ANUL" then do
  707.         if datstr ~= "" then
  708.         PUTENDDATE ff datstr
  709.         if plcstr ~= "" then
  710.         PUTENDPLACE ff plcstr
  711.     PUTENDING ff 4
  712.       end
  713.       else if idstr = "DIV" then do
  714.         if datstr ~= "" then
  715.         PUTENDDATE ff datstr
  716.         if plcstr ~= "" then
  717.         PUTENDPLACE ff plcstr
  718.         PUTENDING ff 2
  719.     /* TO DO: if 'DIV' has a "2 TYPE SEPARAT*" line behind it,
  720.      * set ending to 'Separation'
  721.      */
  722.       end
  723.       else if idstr = "ENGA" then do
  724.         if datstr ~= "" then
  725.         PUTENGAGEDATE ff datstr
  726.         if plcstr ~= "" then
  727.         PUTENGAGEPLACE ff plcstr
  728.       end
  729.     end
  730.     RETURN 0
  731.   end
  732.  
  733.   lvlstr = word(ins, 1)
  734.   lvl = GetNumType(lvlstr)
  735.   if lvl <= inilvl then do
  736.     if ff ~= 0 then do
  737.       if idstr = "MARR" then do
  738.         if datstr ~= "" then
  739.       PUTMARRYDATE ff datstr
  740.         if plcstr ~= "" then
  741.       PUTMARRYPLACE ff plcstr
  742.         if clbrnt ~= "" then
  743.           PUTCELEBRANT ff clbrnt
  744.       end
  745.       else if idstr = "DIV" | idstr = "ANUL" then do
  746.         if datstr ~= "" then
  747.         PUTENDDATE ff datstr
  748.         if plcstr ~= "" then
  749.         PUTENDPLACE ff plcstr
  750.         if idstr = "DIV" then PUTENDING ff 2
  751.     else idstr = "ANUL" then PUTENDING ff 4
  752.       end
  753.       else if idstr = "ENGA" then do
  754.         if datstr ~= "" then
  755.         PUTENGAGEDATE ff datstr
  756.         if plcstr ~= "" then
  757.         PUTENGAGEPLACE ff plcstr
  758.       end
  759.     end
  760.     RETURN ins
  761.   end
  762.   if finp = 0 & ff = 0 then FOutput(ins)
  763.   else do
  764.     if lvl = inilvl+1 then do
  765.       lstr = strip(delstr(ins, 1, length(lvlstr)))
  766.       curr = upper(word(lstr, 1))
  767.       if curr = "DATE" then do
  768.         datstr = strip(delstr(lstr, 1, length(curr)))
  769.       end
  770.       else if curr = "PLAC" then do
  771.         plcstr = strip(delstr(lstr, 1, length(curr)))
  772.       end
  773.       else if curr = "OFFI" then do
  774.         clbrnt = strip(delstr(lstr, 1, length(curr)))
  775.         /* only for "MARR" */
  776.       end
  777.       else if curr = "QUAY" then do
  778.         lstr = strip(delstr(lstr, 1, length(curr)))
  779.         if DATATYPE(lstr) = 'NUM' & lstr <= 1 then do
  780.           if datstr ~= "" then datstr = datstr||'?'
  781.           if plcstr ~= "" then plcstr = plcstr||'?'
  782.         end
  783.       end
  784.     end
  785.     /* Skip all fields of lvl > inilvl */
  786.   end
  787. end
  788. TermError("ERROR: Unexpected end of file (Parsed Family Events)!")
  789.  
  790. GetNewPerson: PROCEDURE EXPOSE infile outp usereq
  791.   PUTNEWPERSON
  792.   newpnum = RESULT
  793.   if newpnum = 0 then TermError("ERROR: Cannot allocate new person!")
  794.   /* if you want to see Scion in action, uncomment the next line */
  795.   /* GETPERSONWIN newpnum */
  796. return newpnum
  797.  
  798. GetNewFamily: PROCEDURE EXPOSE infile outp usereq
  799. parse arg irn
  800.   PUTNEWFAMILY irn
  801.   newfnum = RESULT
  802.   if newfnum = 0 then TermError("ERROR: Cannot allocate new family!")
  803.   /* if you want to see Scion in action, uncomment the next line */
  804.   /* GETFAMILYWIN newfnum */
  805. return newfnum
  806.  
  807. StoreOccup: PROCEDURE
  808. parse arg nstr, pnum
  809.  PUTOCCUPATION pnum nstr
  810. return 1
  811.  
  812. StoreEduc: PROCEDURE
  813. parse arg nstr, pnum
  814.  PUTEDUCATION pnum nstr
  815. return 1
  816.  
  817. StoreRelig: PROCEDURE
  818. parse arg nstr, pnum
  819.  PUTRELIGION pnum nstr
  820. return 1
  821.  
  822. StoreCOD: PROCEDURE
  823. parse arg nstr, pnum
  824.  PUTDIEDOF pnum nstr
  825. return 1
  826.  
  827. StorePersComment: PROCEDURE EXPOSE infile outp usereq lnum
  828. parse arg nstr, pnum, lvl
  829.  PUTPERSCOMMENT pnum nstr
  830.  l1 = lvl||" CONT"
  831.  l2 = lvl||" CONC"
  832.  l3 = length(l1)
  833.  ins = GetNextLine()
  834.  if length(ins) > l3 & (left(ins, l3) = l1 | left(ins, l3) = l2) then do
  835.    StorePersRefs(right(ins, length(ins)-l3), pnum)
  836.    ins = GetNextLine()
  837.  end
  838. return ins
  839.  
  840. StorePersRefs: PROCEDURE
  841. parse arg nstr, pnum
  842.  PUTPERSREFS pnum nstr
  843. return 1
  844.  
  845. StoreFamHusband: PROCEDURE EXPOSE errfile infile outp usereq lnum IRNArr. FGRNArr.
  846. parse arg nstr, fnum
  847.   nstr = compress(nstr,'@ ')
  848.   ff = 0
  849.   ii = GGetIRN(nstr)
  850.   if ii = 0 then
  851.     writeln(errfile, "ERROR: Missing Personal Record for HUSBAND "||nstr||" (line: "||lnum||")")
  852.   else do
  853.     ff = GGetFGRN(fnum)
  854.     if ff = 0 then do
  855.     ff = GetNewFamily(ii)
  856.     FGRNArr.0 = FGRNArr.0||fnum||' '
  857.     FGRNArr.1 = FGRNArr.1||ff||' '
  858.     end
  859.     else do
  860.     /* There already is a family, so there is a principal; assume
  861.      * that that is the wife - add the husband as spouse
  862.      */
  863.       PUTSPOUSE ff ii
  864.     ers = RESULT
  865.     if ers ~= 1 then do
  866.         writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (HUSB) "||ff||' '||ii)
  867.       GETPRINCIPAL ff
  868.       prc = RESULT
  869.       GETSPOUSE ff
  870.       spc = RESULT
  871.       writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
  872.     end
  873.     end
  874.   end
  875. return ff
  876.  
  877. StoreFamWife: PROCEDURE EXPOSE errfile infile outp usereq lnum IRNArr. FGRNArr.
  878. parse arg nstr, fnum
  879.   nstr = compress(nstr,'@ ')
  880.   ff = 0
  881.   ii = GGetIRN(nstr)
  882.   if ii = 0 then
  883.     writeln(errfile, "ERROR: Missing Personal Record for WIFE "||nstr||" (line: "||lnum||")")
  884.   else do
  885.     ff = GGetFGRN(fnum)
  886.     if ff = 0 then do
  887.       ff = GetNewFamily(ii)
  888.     FGRNArr.0 = FGRNArr.0||fnum||' '
  889.     FGRNArr.1 = FGRNArr.1||ff||' '
  890.     end
  891.     else do
  892.       PUTSPOUSE ff ii
  893.     ers = RESULT
  894.     if ers ~= 1 then do
  895.         writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (WIFE) "||ff||' '||ii)
  896.       GETPRINCIPAL ff
  897.       prc = RESULT
  898.       GETSPOUSE ff
  899.       spc = RESULT
  900.       writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
  901.     end
  902.     end
  903.   end
  904. return ff
  905.  
  906. StoreFamChild: PROCEDURE EXPOSE errfile infile outp usereq lnum IRNArr. FGRNArr.
  907. parse arg nstr, fnum
  908. /* TO DO: improve this function, to allow definition of children here,
  909.  *      instead of in a separate personal record. Also look for "ADOP"
  910.  *      field (adopted children)
  911.  */
  912.   if fnum = 0 then RETURN 0
  913.     /* we cannot parse a child when there is no family yet */
  914.   nstr = compress(nstr,'@ ')
  915.   ii = GGetIRN(nstr)
  916.   if ii = 0 then
  917.     writeln(errfile, "ERROR: Missing Personal Record for CHILD "||nstr||" (line: "||lnum||")")
  918.   else do
  919.     PUTCHILD fnum ii
  920.     ers = RESULT
  921.     if ers ~= 1 then
  922.       writeln(errfile, "ERROR "||ers||" in PUTCHILD "||fnum||' '||ii||" (line: "||lnum||")")
  923.   end
  924. return 1
  925.  
  926. StoreFamRefs: PROCEDURE EXPOSE infile outp usereq
  927. parse arg nstr, fnum
  928. if fnum ~= 0 then
  929.   PUTFAMREFS fnum nstr
  930.  /* Note: I use it as a CONT field for comments */
  931. return 1
  932.  
  933. StoreFamComment: PROCEDURE EXPOSE infile ffile outp usereq lnum finp FGRNArr.
  934. parse arg nstr, ff, lvl
  935.   if ff ~= 0 then
  936.     PUTFAMCOMMENT ff nstr
  937.   l1 = lvl||" CONT"
  938.   l2 = lvl||" CONC"
  939.   l3 = length(l1)
  940.   ins = GetNextFLine()
  941.   if length(ins) > l3 & (left(ins, l3) = l1 | left(ins, l3) = l2) then do
  942.     if finp = 0 & ff = 0 then
  943.       FOutput(ins)
  944.     else
  945.       StoreFamRefs(right(ins, length(ins)-l3), ff)
  946.     ins = GetNextFLine()
  947.   end  
  948. return ins
  949.  
  950. /* Return the Scion IRN belonging to the GEDCOM Personal number pnum */
  951. GGetIRN: PROCEDURE EXPOSE IRNArr.
  952. parse arg pnum
  953. anum = find(IRNArr.0, pnum)
  954. if anum > 0 then
  955.   return word(IRNArr.1, anum)
  956. else
  957.   return 0
  958.  
  959. /* Return the Scion FGRN belonging to the GEDCOM Family number fnum */
  960. GGetFGRN: PROCEDURE EXPOSE lnum FGRNArr.
  961. parse arg fnum
  962. anum = find(FGRNArr.0, fnum)
  963. if anum > 0 then
  964.   return word(FGRNArr.1, anum)
  965. else
  966.   return 0
  967.  
  968. SkipChanged: PROCEDURE EXPOSE infile lnum
  969. parse arg inlvl
  970. lvl = inlvl + 1
  971. do until lvl <= inlvl
  972.   ins = GetNextLine()
  973.   lvlstr = word(ins, 1)
  974.   lvl = GetNumType(lvlstr)
  975. end
  976. return ins
  977.  
  978. /*
  979.  * Procedure to strip the directory path from the string,
  980.  * only leaving the filename
  981.  */
  982. StripPath: PROCEDURE
  983. parse arg str
  984.   p = lastpos('/', str)
  985.   if p > 0 then ret1 = delstr(str,1,p)
  986.   else ret1 = str
  987.   p = lastpos(':', ret1)
  988.   if p > 0 then retstr = delstr(ret1,1,p)
  989.   else retstr = ret1
  990. return retstr
  991.  
  992. Tell: PROCEDURE EXPOSE outp
  993. parse arg str
  994. if outp then writeln(stdout, str)
  995. return 0
  996.  
  997. TellNN: PROCEDURE EXPOSE outp
  998. parse arg str
  999. if outp then writech(stdout, str)
  1000. return 0
  1001.  
  1002. TermError: PROCEDURE EXPOSE infile outp usereq pgopen
  1003. parse arg str
  1004. if pgopen then Postmsg()
  1005. /* If you turned off stdout, no error messages will be shown! */
  1006. if usereq then
  1007.   rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = SCIONGEN')
  1008. else
  1009.   Tell(str || '0A'x)
  1010. if exists("T:Scion.GPF") then
  1011.   ADDRESS COMMAND delete "T:Scion.GPF" QUIET
  1012. close(infile)
  1013. EXIT
  1014.  
  1015. /* Let's make sure you get a nice message when you turn off the printer :-) */
  1016.  
  1017. IOERR:
  1018.   bline = SIGL
  1019.   say "I/O error #"||RC||" detected in line "||bline||":"
  1020.   say sourceline(bline)
  1021.   if pgopen then Postmsg()
  1022.   EXIT
  1023.