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