?? right := 110, fmt (keyw := lower, ident := lower) ??
?? push(list := on) ??

module extract_records_from_library alias 'mextrac';

{ Author : John Farr -- May 4, 1979. }

{}
{    EXTRACT is a program that enables easy retrieval of records
{ from permanent file (or local) libraries.
{
{    Although the program  is  designed  primarily  for  use  in
{ procedure files, it can be very useful on its own.
{
{    EXTRACT is  similar in function to the NOS "GTR" statement.
{ It differs from "GTR" in the following ways:
{
{    o  EXTRACT insists that the library to be  searched  has  a
{       directory  (this  can  be  built  using  the NOS utility
{       "LIBEDIT").
{
{    o  The record type parameter for EXTRACT, if given, applies
{       to  all  records to be extracted, and if not given, only
{       the names of the records are  used  when  searching  the
{       library.
{
{    o  Each extracted record is copied to its own local file by
{       EXTRACT, rather than all to the same file.
{
{    o  EXTRACT does not insist that the library to be  searched
{       be  local  to the job when it's called, but will ACQUIRE
{       the library from a permanent file catalog.
{
{
{    The control statement format is:
{
{
{           EXTRACT(lfn1=rn1,lfn2=rn2,.../op1,op2,...)
{
{ lfni   Is the local file name given to the  record  once  it's
{        extracted   (lfni  is  REWOUND  before  and  after  the
{        extraction takes place).
{
{ rni    Is the name of the record to be extracted (if  omitted,
{        it is assumed to be the same as lfni).
{
{ opi    These parameters   specify  options  that  control  the
{        extraction process :
{
{        A            Specifies that if a record is  not  found,
{                     the program should abort.
{
{        NA           Is the   opposite   of   A   (and  is  the
{                     default).
{
{        T=rt         Specifies the record type  (if  given,  it
{                     applies to all records being extracted; if
{                     omitted, only the record  names  are  used
{                     when searching the library).
{
{        L=libname    Specifies the  name  of  the library to be
{                     searched  for  the  records  (if  omitted,
{                     "PROCLIB" is assumed).
{
{        LFN=liblfn   Specifies the  local  file  name  for  the
{                     library (if omitted,  the  "libname"  from
{                     the  L  paraeter is used).  Note that this
{                     is the name used  to  make  the  "is  file
{                     local?" test when ACQUIRing the library.
{
{        UN=un        Specifies the  user  name of the permanent
{                     file catalog to be searched for  "libname"
{                     if it's not already local (if omitted, the
{                     current user is assumed).
{
{        PW=pw        Specifies the  library's  permanent   file
{                     password.
{
{        PN=pn        Specifies the   library's  permanent  file
{                     packname.
{
{
{    Valid record type  designators  are  documented  under  the
{ description  of  the  "CATALOG"  control  statement in the NOS
{ Reference Manual.
{
{    In addition to  these  standard  types,  there's  one  more
{ "type"  processed  by  EXTRACT,  which is designated by "TXT".
{ This "type" is  used  to  denote  "TEXT"  records  that,  when
{ extracted,  are  to  have their first line (which contains the
{ record's  name)  "stripped  off".   This  is  useful  if,  for
{ example,  one  has  records  containing  directives  for a NOS
{ utility, in which case the name of such a  record  is  in  all
{ likelihood an illegal directive to the utility program.
{
{
{    EXTRACT will abort under any of the following conditions:
{
{    o  format or argument error(s) on the control statement
{
{    o  the specified library could not be AQUIREd
{
{    o  the library  file  does not have a directory as the last
{       record before end-of-information
{
{    Note, however, that EXTRACT won't abort if it does not find
{ any  of  the  requested  records  (only an informative dayfile
{ message is issued), unless the Abort parameter  was  coded  on
{ the call.
{
{    If  the  library file was not local to the job when EXTRACT
{ was called,  it  will  be  RETURNed  when  EXTRACT  terminates
{ normally;  but,  if  the  library file was local, EXTRACT will
{ REWIND it prior to normal termination.
{}

  ?? eject ??
*copyc pxiotyp
*copyc bizopen
*copyc bizclos
*copyc bizget
*copyc bizput
*copyc fzwords
*copyc fzmark
*copyc pxziobs

*copyc zuttpfd
*copyc zn7pcio
*copyc zn7pwnb

*copyc zuttdcn
*copyc zutcdcn
*copyc zn7tsrt
*copyc zn7tjca
*copyc zn7prdr
*copyc zutpaqr
*copyc zutpdcg
*copyc zutpdci
*copyc zutpdcp
*copyc zutpdns
*copyc zutpmsg
*copyc zutpabt
*copyc zn7pmsg

  ?? eject ??

  program extract;

    const
      any_type = - 2,
      txt_type = - 1;

    var
      jca alias 'sw=ra0': [xref] n7t$job_communication_area,
      ccdr_src_ptr: cell,
      ccdr_dest_ptr: cell,
      ccdr_ch: 0 .. 3f(16),
      arg_keys: [static] array[0 .. 7] of utt$dc_name := [utc$dc_a, utc$dc_na, utc$dc_t, utc$dc_lfn, utc$dc_l,
        utc$dc_un, utc$dc_pw, utc$dc_pn],
      lib_args: [static] array[3 .. 7] of string (7) := ['  ', 'PROCLIB', '  ', '  ', '  '],
      key_index: 0 .. 7,
      record_type_table: [static, read] array[0 .. 13] of record
        name: utt$dc_name,
        code: txt_type .. n7c$proc,
      recend := [[utc$dc_txt, txt_type], [utc$dc_text, n7c$text], [utc$dc_pp, n7c$pp], [utc$dc_cos, n7c$cos],
        [utc$dc_rel, n7c$rel], [utc$dc_ovl, n7c$ovl], [utc$dc_ulib, n7c$ulib], [utc$dc_opl, n7c$opl],
        [utc$dc_oplc, n7c$oplc], [utc$dc_opld, n7c$opld], [utc$dc_abs, n7c$abs], [utc$dc_ppu, n7c$ppu],
        [utc$dc_cap, n7c$cap], [utc$dc_proc, n7c$proc]],
      record_type_index: 0 .. 13,
      requested_record_type: [static] any_type .. n7c$proc := any_type,
      actual_record_type: n7c$text .. n7c$proc,
      lfn_rn_table: array[1 .. 50] of record
        lfn: utt$dc_name,
        rn: utt$dc_name,
      recend,
      num_records: [static] 0 .. 50 := 0,
      record_index: 1 .. 50,
      record_file: file,
      lib_file: file,
      record_lfn: string (7),
      ignore_length: 0 .. 7,
      skip_text_record_name: cell,
      copy_buffer: array[0 .. 400(16)] of cell,
      words_read: integer,
      f_mark: file_mark,
      record_not_found: [static] boolean := false,
      sep_codes: [static, read] string (64) :=
        ',,=/(+-~;~~~~~~,~~~~~~~~~~~~~~~~~~~~~+-*/(~$=~,,#[]%"_!&''?<>@\^;',
      arg: utt$dc_name,
      sep: char,
      arg_index: [static] integer := 0,
      arg_count: integer,
      abort_when_record_not_found: [static] boolean := false,
      acquire_response: utt$acquire_response_codes,
      directory_index: integer,
      directory_ptr: ^n7t$opld_directory,
      lib_file_desc_ptr: ^utt$pascalx_file_descriptor;

    const
      format_error = '- FORMAT ERROR';

    var
      not_found_message: [static] string (30) := '- CAN''T FIND RECORD - ',
      missing_directory_message: [static] string (39) := '- MISSING OR BAD DIRECTORY ON - ';



    procedure next_arg;

      arg_index := arg_index + 1;
      if arg_index <= arg_count then
        arg := jca.argr[arg_index].arg;
        sep := sep_codes (jca.argr[arg_index].sep + 1);
      ifend;
      if (arg_index > arg_count) or (arg = 0) then
        utp$issue_dayfile_message (format_error);
        utp$abort;
      ifend;

    procend next_arg;



    var
      ccdr_dest_ptr_int_ptr: ^integer,
      ccdr_src_ptr_int_ptr: ^integer;

    arg_count := jca.actr;
    if (arg_count > 0) and (jca.argr[jca.actr].sep = 0) then
    /suppress_password/
      begin
        utp$create_dc_string_ptr (#loc (jca.ccdr), 0, ccdr_src_ptr);
        repeat
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
        until ccdr_ch = 28(16) {/} ;
      /find_password/
        while true do
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
          if ccdr_ch <> 10(16) {P} then
            cycle /find_password/;
          ifend;
          ccdr_dest_ptr := ccdr_src_ptr;
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
          if ccdr_ch <> 17(16) {W} then
            ccdr_src_ptr := ccdr_dest_ptr;
            cycle /find_password/;
          ifend;
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
          if ccdr_ch = 0 then
            exit /suppress_password/;
          ifend;
          if ccdr_ch = 2c(16) {=} then
            exit /find_password/;
          ifend;
          ccdr_src_ptr := ccdr_dest_ptr;
        whilend /find_password/;
        ccdr_dest_ptr := ccdr_src_ptr;
        repeat
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
        until (ccdr_ch >= 25(16)) and (ccdr_ch <> 27(16));
        repeat
          utp$insert_next_dc_char (ccdr_dest_ptr, ccdr_ch);
          utp$get_next_dc_char (ccdr_src_ptr, ccdr_ch);
        until ccdr_ch = 0;
        ccdr_dest_ptr_int_ptr := #loc (ccdr_dest_ptr);
        ccdr_src_ptr_int_ptr := #loc (ccdr_src_ptr);
        while ccdr_dest_ptr_int_ptr^ <> ccdr_src_ptr_int_ptr^ do
          utp$insert_next_dc_char (ccdr_dest_ptr, 0);
        whilend;
      end /suppress_password/;
      n7p$issue_dayfile_message (#loc (jca.ccdr), 3);
    else
      if arg_count = 0 then
        n7p$issue_dayfile_message (#loc (jca.ccdr), 3);
      ifend;
    ifend;

    repeat
      num_records := num_records + 1;
      next_arg;
      lfn_rn_table[num_records].lfn := arg;
      if sep = '=' then
        next_arg;
      ifend;
      lfn_rn_table[num_records].rn := arg;
      if sep = '=' then
        utp$issue_dayfile_message (format_error);
        utp$abort;
      ifend;
    until (sep = '/') or (arg_index = arg_count);

  /advance_arg/
    while arg_index < arg_count do
      next_arg;
      for key_index := 0 to 7 do
        if arg_keys[key_index] = arg then
          if ((key_index <= 1) and (sep = '=')) or ((key_index > 1) and (sep <> '=')) then
            utp$issue_dayfile_message (format_error);
            utp$abort;
          ifend;
          if key_index > 1 then
            next_arg;
            if sep = '=' then
              utp$issue_dayfile_message (format_error);
              utp$abort;
            ifend;
          ifend;
          case key_index of
          =0 .. 1=
            arg_keys[0] := 0;
            arg_keys[1] := 0;
            abort_when_record_not_found := key_index = 0;
          =2=
            arg_keys[2] := 0;
            for record_type_index := 0 to 13 do
              if record_type_table[record_type_index].name = arg then
                requested_record_type := record_type_table[record_type_index].code;
                if requested_record_type <> txt_type then
                  actual_record_type := requested_record_type;
                else
                  actual_record_type := n7c$text;
                ifend;
                cycle /advance_arg/;
              ifend;
            forend;
            utp$issue_dayfile_message ('- INVALID RECORD TYPE');
            utp$abort;
          =3 .. 7=
            arg_keys[key_index] := 0;
            utp$convert_dc_name_to_string (arg, lib_args[key_index], ignore_length);
          casend;
          cycle /advance_arg/;
        ifend;
      forend;
      utp$issue_dayfile_message ('- ARGUMENT ERROR');
      utp$abort;
    whilend /advance_arg/;

    if lib_args[3] = '       ' then
      lib_args[3] := lib_args[4];
    ifend;
    utp$acquire_file (lib_args[3], lib_args[4], lib_args[5], lib_args[6], lib_args[7], n7c$pfm_m_read,
      utc$acquire_anywhere, acquire_response);
    if acquire_response = utc$acquire_error then
      utp$abort;
    else
      if acquire_response = utc$acquire_not_found then
        not_found_message (14, 10) := 'LIBRARY - ';
        not_found_message (24, 7) := lib_args[4];
        utp$issue_dayfile_message (not_found_message);
        utp$abort;
      ifend;
    ifend;

    px#iobs := 401(16);
    bi#open (lib_file, lib_args[3], old#, input#, asis#);
    lib_file_desc_ptr := #loc (lib_file^);
    lib_file_desc_ptr^.fet.random := true;
    lib_file_desc_ptr^.fet.extension_length := 2;
    n7p$get_opld_directory (lib_file, directory_ptr);
    if directory_ptr = nil then
      if acquire_response = utc$acquire_was_local then
        bi#close (lib_file, first#);
      else
        bi#close (lib_file, return#);
      ifend;
      missing_directory_message (33, 7) := lib_args[4];
      utp$issue_dayfile_message (missing_directory_message);
      utp$abort;
    ifend;

  /next_record/
    for record_index := 1 to num_records do
      for directory_index := lowerbound (directory_ptr^) to upperbound (directory_ptr^) do
        if (lfn_rn_table[record_index].rn = directory_ptr^[directory_index].record_name) and
          ((requested_record_type = any_type) or (actual_record_type = directory_ptr^[directory_index].
            record_type)) then
          n7p$wait_not_busy (#loc (lib_file_desc_ptr^.fet));
          lib_file_desc_ptr^.control.initial_read := true;
          lib_file_desc_ptr^.fet.rr := directory_ptr^[directory_index].random_address;
          if requested_record_type = txt_type then
            bi#get (lib_file, #loc (skip_text_record_name), 1);
          ifend;
          utp$convert_dc_name_to_string (lfn_rn_table[record_index].lfn, record_lfn, ignore_length);
          bi#open (record_file, record_lfn, old#, output#, first#);
          repeat
            bi#get (lib_file, #loc (copy_buffer), #size (copy_buffer));
            f#words (lib_file, words_read);
            if words_read > 0 then
              bi#put (record_file, #loc (copy_buffer), words_read);
            ifend;
            f#mark (lib_file, f_mark);
          until f_mark <> data#;
          bi#close (record_file, first#);
          cycle /next_record/;
        ifend;
      forend;
      record_not_found := true;
      utp$convert_dc_name_to_string (lfn_rn_table[record_index].rn, not_found_message (23, 7), ignore_length);
      utp$issue_dayfile_message (not_found_message);
      if abort_when_record_not_found then
        exit /next_record/;
      ifend;
    forend /next_record/;

    if acquire_response = utc$acquire_was_local then
      bi#close (lib_file, first#);
    else
      bi#close (lib_file, return#);
    ifend;
    if abort_when_record_not_found and record_not_found then
      utp$abort;
    ifend;

  procend extract;

  ?? eject ??
{ The following procedure replaces the "standard" program initializer
{ contained in the run-time library.  Unlike the standard version this
{ one does not open file OUTPUT (or any other file for that matter)
{ for two reasons: 1. doing so may be an anomaly if the program is
{ to acquire file OUTPUT; and 2. any errors detected by the reprieve
{ processor will now show up only in the dayfile.
{ The same procedure names as those in the run-time library are used
{ so that correlation is made easier.


  procedure [xdcl] crunrma alias 'sw=mama';

*copyc pxiotyp

    procedure [xref] rpvinit alias 'sw=erri' (fileptr: ^file;
      procptr: ^procedure);

    rpvinit (nil, nil);

  procend crunrma;

modend extract_records_from_library;
