Fresh Fish 10/Fresh_Fish_10_2352.bin/new/biz/dbase/genealogist/scionarexx.lha/Links.rexx

OS/2 REXX Batch file | 1995-06-02 | 9.4 KB | 358 lines

/****************************************************************************
 *                                                                          *
 * $VER: Links 1.15 (23 May 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 *                                                                          *
 * 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 version 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, change the line 'usereq = 1' to 'usereq = 0'   *
 *                                                                          *
 * New (requested by Robbie): progress indicator, using rexxarplib.library  *
 *                                                                          *
 ****************************************************************************/

options results
arg outname outval

versionstr = "1.15"
usereq = 1; /* change this to 0 if you don't want to use reqtools */
useirn = 1
outp = 1; output = stdout
plwidth = 78;  /* linewidth of the printer */
fill = 9;      /* number of spaces at the beginning of lines */
prgrs = 1; pgopen = 0; /* use RexxArp progress indicator */
  /* change prgrs to 0 for not using it */
NL = '0A'x

signal on IOERR

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

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

/* These first few lines were stolen from Peter Billings - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  TermError('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

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
  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 = SCIONGEN')
      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 = SCIONGEN   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): ")
      pull outname
      Tell("Destination: "||outname)
      TellNN("Continue (y/n)? ")
      pull conf
      /* Note that left works on empty strings ("") too! */
      if left(conf,1) ~= "Y" then do
        Tell("Goodbye...")
        EXIT
      end
      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||"\ \ ", "SCIONGEN")
  pgopen = 1
end

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

do while CurrIRN ~= TotalIRN
  if pgopen then Postmsg(,,"\\\"||CurrIRN||" (of "||TotalIRN||")", "SCIONGEN")
  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...\ ", "SCIONGEN")

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

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

if pgopen then do
  Postmsg()
  pgopen = 0
end

if usereq then do
  rtezrequest('Scion Links Finder is ready.' || NL ||'Persons parsed: '||,
    TotalIRN,,'Links Message:','rt_pubscrname = SCIONGEN')
end
else
  Tell("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
parse arg ostr, fill
do while ostr ~= ""
  nnl = plwidth+1
  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)
      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
  writeln(output, prtstr)
  if ostr ~= "" then
    ostr = copies(' ',fill)||ostr
end
return 0

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

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

TermError: PROCEDURE EXPOSE outp output usereq pgopen
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 = SCIONGEN')
else do
  Tell(str || '0A'x)
end
/* close(output) */
EXIT

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