Aminet 10/aminetcdnumber101996.iso/Aminet/util/rexx/ScionRexx.lha/Links.rexx

OS/2 REXX Batch file | 1995-11-01 | 12KB | 422 lines

/****************************************************************************
 *                                                                          *
 * $VER: Links 1.18 (31 Oct 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 * Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands.          *
 *                                                                          *
 * ARexx script to find unrelated family trees in the database              *
 * It will detect all family trees within the database that have no links   *
 * (spouse, parent or child links) to other present family trees.           *
 * Eg. useful to find out if you forgot to add a link somewhere...          *
 *                                                                          *
 * This script uses (by default) the rexxreqtools.library (which requires   *
 * a version of reqtools larger than 2.0 and rexxsyslib.library)            *
 * If you do not have these, run SetDefaults.rexx to change the settings.   *
 *                                                                          *
 * DONE:                                                                    *
 * - progress indicator, using rexxarplib.library (requested by R.Akins)    *
 * - now uses preference file for default settings                          *
 *                                                                          *
 ****************************************************************************/

options results
arg outname outval

versionstr = "1.18"

/* Don't change the settings here! Run SetDefaults.rexx instead! */
usereq = 1; prgrs = 1; pgopen = 0
outp = 1; output = stdout; scrdev = stdout
PSCR = 'SCIONGEN'
plwidth = 78; pgsize = 0

fill = 4;      /* number of spaces at the beginning of lines */
useirn = 1; pgline = 1
scrname = "CON:0//639//Scion Output/AUTO/SCREEN"
NL = '0A'x

signal on IOERR

do while outname = '?'
  writeln(stdout, "OUTFILE/A,QUIET/S,NOREQ/S ")
  pull outname outval
end

/* read preferences file */

if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
  do while ~eof(pfile)
    inln = readln(pfile)
    if inln ~= "" then do
      wstr = upper(word(inln, 1))
      if wstr = "USEREQ" then
        usereq = 1
      else if wstr = "NOUSEREQ" then
        usereq = 0
      else if wstr = "PROGRESS" then
        prgrs = 1
      else if wstr = "NOPROGRESS" then
        prgrs = 0
      else if wstr = "PUBSCREEN" then
        pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
      else if wstr = "LINEWIDTH" then do
        wstr = word(inln, 2)
        if datatype(wstr, 'w') then plwidth = wstr
      end
      else if wstr = "PAGESIZE" then do
        wstr = word(inln, 2)
        if datatype(wstr, 'w') then pgsize = wstr
      end
    end
  end
  close(pfile)
end

if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
  pscr = "SCIONGEN"
scrname = scrname||pscr

/* command line options get priority over global settings */

if outname ~= "" then do
  if outname = "QUIET" | outname = "NOREQ" then do
    outval = outname; outname = ""
  end
end

if outval = "QUIET" then do
  outp = 0; usereq = 0; prgrs = 0
end
else if outval = "NOREQ" then do
  usereq = 0; prgrs = 0
end

if usereq & ~show('l','rexxreqtools.library') then do
  if exists('libs:rexxreqtools.library') then
    call addlib('rexxreqtools.library',0,-30,0)
  else do
    usereq = 0; outp = 1
    Tell("Unable to open rexxreqtools.library - using text output")
  end
end

if ~usereq then prgrs = 0

/* Originally stolen from Peter Billing - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  EndString('I am sorry to say that the SCION Genealogist' || NL ||,
    'database is not available. Please start the' || NL ||,
    'SCION program BEFORE using this script!')
end

if prgrs & ~show('l','rexxarplib.library') then do
  if exists('libs:rexxarplib.library') then
    call addlib('rexxarplib.library',0,-30,0)
  else
    prgrs = 0
end

screentofront(pscr)

myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)

Arrays. = ""
CurrIRN = 1; arr = 1; Arrays.1 = "1 "
NumArrs = 1; Found = 1

if outp & ~usereq then do
  if pscr ~= "WORKBENCH" then do
    scrdev = 'SCNLNKSCR'
    if ~open(scrdev, scrname, 'w') then scrdev = stdout
  end
  Tell("Scion Links Finder v"||versionstr||" by Freddy Ariës")
  Tell("Current Scion database: "||dbname)
  Tell("Be patient - this may take a while...")
end

/* It's a good habit to add the ".scion" extension to Scion database files */
dblen = length(dbname)
if dblen>6 & right(dbname, 6)=".SCION" then dbname=left(dbname, dblen - 6)

if outname = "" then do
  if outp then do
    if usereq then do
      odev = rtezrequest('Current Scion database: '||dbname||,
       NL||'Where should the Links output be sent to?'||,
       NL,' _File |_Printer|_Screen|_Nowhere','Scion Links Finder v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
      select
        when odev = 1 then do
          /* We need a file requester for further data */
          outname = rtfilerequest(,dbname||'.LNK','Output filename',,'rtfi_buffer = true   rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
          if outname = '' then
            outname = dbname||'.LNK'
        end
        when odev = 2 then
          outname = 'PRT:'
        when odev = 3 then
          outname = 'STDOUT'
        otherwise
          EXIT
          /* You selected 'Nowhere' */
      end
    end
    else do
      Tell("Enter output file (filename with complete path, or PRT: for printer,")
      TellNN("or STDOUT for screen): ")
      outname = readln(scrdev)
      outname = strip(outname, 'b', ' "')
      Tell("Destination: "||outname)
      TellNN("Continue (y/n)? ")
      conf = readln(scrdev)
      conf = upper(left(conf, 1))
      /* Note that left works on empty strings ("") too! */
      if conf ~= "Y" then
        EndString("Goodbye...")
      Tell("")
    end
  end
  else
    outname = "RAM:"dbname".LNK"
    /* If we're not allowed to use stdout, default to this filename */
end

if prgrs then do
  Postmsg(10, 10, "Scion Links Finder (by Freddy Ariës)\Database: "||dbname||"\ \ ", PSCR)
  pgopen = 1
end

GETTOTALIRN
TotalIRN = RESULT
if pgopen then Postmsg(,, "\\Processing person:\", PSCR)

do while CurrIRN <= TotalIRN
  if pgopen then Postmsg(,,"\\\"||CurrIRN||" (of "||TotalIRN||")", PSCR)
  if Found then do
    MarrNum = 0; marrexist = 1

    do while marrexist
      GETMARRIAGE CurrIRN MarrNum
      marriage = RESULT
      EXISTFAMILY marriage
      if RESULT = 'YES' then do
        marrexist = 1

    PrsnIRN = 0
    GETPRINCIPAL marriage
    ptnr = RESULT
    EXISTPERSON ptnr
    if RESULT = 'YES' then do
      if ptnr ~= CurrIRN then PrsnIRN = ptnr
    end
    if PrsnIRN = 0 then do
      GETSPOUSE marriage
      ptnr = RESULT
      EXISTPERSON ptnr
      if RESULT = 'YES' then do
        if ptnr ~= CurrIRN then PrsnIRN = ptnr
      end
    end

    EXISTPERSON PrsnIRN
        if RESULT = 'YES' then
          arr = HandlePerson(PrsnIRN)

    ChildNum = 0; childexist = 1
    do while childexist
      GETCHILD marriage ChildNum
      child = RESULT
      EXISTPERSON child
      if RESULT = 'YES' then do
            childexist = 1
        arr = HandlePerson(child)
        ChildNum = ChildNum + 1
      end
      else childexist = 0
    end

        MarrNum = MarrNum + 1
      end
      else marrexist = 0
    end

    GETPARENTS CurrIRN
    ParFGRN = RESULT
    EXISTFAMILY ParFGRN
    if RESULT = 'YES' then do
      GETPRINCIPAL ParFGRN
      PrsnIRN = RESULT
      EXISTPERSON PrsnIRN
      if RESULT = 'YES' then do
        arr = HandlePerson(PrsnIRN)
      end

      GETSPOUSE ParFGRN
      PrsnIRN = RESULT
      EXISTPERSON PrsnIRN
      if RESULT = 'YES' then
        arr = HandlePerson(PrsnIRN)

      /* Note that we don't have to process siblings, because they will
       * be processed with their parents, and because you cannot create
       * a family group without at least one parent
       */
    end
  end

  CurrIRN = CurrIRN + 1
  EXISTPERSON CurrIRN

  if RESULT = 'YES' then do
   arr = GetArray(CurrIRN)
   Found = 1
  end
  else Found = 0
end

if pgopen then Postmsg(,, "\\Writing output...\ ", PSCR)

if outname ~= "STDOUT" then do
  output = 'OUTPUT'
  if ~open(output, outname, "w") then
    EndString("ERROR: Unable to open output file.")
end
else
  output = scrdev

/* Now output the resulting arrays of IRNs! */
do out = 1 for NumArrs
  PrintLines("Group "||out||": "||Arrays.out, fill)
end

if usereq then do
  rtezrequest('Scion Links Finder is ready.' || NL ||'Persons parsed: '||,
    TotalIRN,'_Ok','Links Message:','rt_pubscrname = '||PSCR)
  if pgopen then Postmsg()
end
else
  EndString("Done ("||TotalIRN||" persons parsed)."||NL)

EXIT

GetArray: PROCEDURE EXPOSE Arrays. NumArrs
parse arg prsn
do CurrArr = 1 for NumArrs
  col = find(Arrays.CurrArr, prsn)
  if col > 0 then return CurrArr
end
/* Not already present, then give person a new array */
NumArrs = NumArrs + 1
Arrays.NumArrs = prsn||' '
return NumArrs

MergeArrs: PROCEDURE EXPOSE Arrays. NumArrs
parse arg arr1, arr2
if arr1 <= arr2 then do
  minarr = arr1; maxarr = arr2
end
else do
  minarr = arr2; maxarr = arr1
end
Arrays.minarr = Arrays.minarr||Arrays.maxarr
if maxarr ~= NumArrs then
  Arrays.maxarr = Arrays.NumArrs
Arrays.NumArrs = ""
NumArrs = NumArrs - 1
return minarr

HandlePerson: PROCEDURE EXPOSE Arrays. NumArrs arr
parse arg prsn
CurrArr = 1; pers = 0
do until pers ~=  0 | CurrArr > NumArrs
  if find(Arrays.CurrArr, prsn) > 0 then pers = CurrArr
  CurrArr = CurrArr + 1
end
if pers = 0 then do
  /* Person isn't already present; give him same array as CurrIRN person */
  pers = arr
  Arrays.arr = Arrays.arr||prsn||' '
end
if pers ~= arr then
  arr = MergeArrs(pers, arr)
return arr

PrintLines: PROCEDURE EXPOSE output plwidth pgline pgsize
parse arg ostr, fill
do while ostr ~= ""
  nnl = plwidth
  if length(ostr) >= plwidth then do
    do until pc = ' ' | nnl = 1
      pc = substr(ostr, nnl, 1)
      nnl = nnl - 1
    end
    if nnl = 1 then do
      prtstr = left(ostr, plwidth-1)
      ostr = delstr(ostr, 1, nnl)
    end
    else do
      prtstr = left(ostr, nnl)
      ostr = delstr(ostr, 1, nnl+1)
    end
  end
  else do
    prtstr = ostr
    ostr = ""
  end
  DoWrite(output, prtstr)
  if ostr ~= "" then
    ostr = copies(' ',fill)||ostr
end
return 0

/*
 * output at most #pgsize lines per page to the print device
 * if pgsize = 0, this feature is turned off (unlimited #lines per page)
 */
DoWrite: PROCEDURE EXPOSE pgline pgsize
parse arg prtdev, ostr
if pgsize ~= 0 & pgline > pgsize then do
  writech(prtdev, '0C'x); /* CTRL-L; next page */
  pgline = 0
end
writeln(prtdev, ostr)
pgline = pgline + 1
return 0

Tell: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writeln(scrdev, str)
return 0

TellNN: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writech(scrdev, str)
return 0

EndString: PROCEDURE EXPOSE outp output usereq pgopen scrdev pscr
parse arg str
if pgopen then Postmsg()
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','Links Message:','rt_pubscrname = '||PSCR)
else do
  Tell(str || '0A'x)
end
if outp & ~usereq & (scrdev ~= stdout) then do
  Tell("Press <return> to exit.")
  readln(scrdev)
  close(scrdev)
end
close(output)
EXIT

IOERR:
  bline = SIGL
  say "I/O error #"||RC||" detected in line "||bline||":"
  say sourceline(bline)
  if pgopen then Postmsg()
  EXIT