Google
 

Trailing-Edge - PDP-10 Archives - bb-h138f-bm - 7-sources/diudo.b36
There are 4 other files named diudo.b36 in the archive. Click here to see a list.
%TITLE 'Process file requests using RMS'

MODULE DIUDO (IDENT = '270',
              LANGUAGE(BLISS36),
              ENTRY(DIU$DO)
              ) =
BEGIN

!	COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1986.
!	ALL RIGHTS RESERVED.
!
!	THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY  BE  USED  AND
!	COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
!	THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE.   THIS  SOFTWARE  OR
!	ANY  OTHER  COPIES  THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
!	AVAILABLE TO ANY OTHER PERSON.  NO TITLE TO AND OWNERSHIP OF  THE
!	SOFTWARE IS HEREBY TRANSFERRED.
!
!	THE INFORMATION IN THIS SOFTWARE IS  SUBJECT  TO  CHANGE  WITHOUT
!	NOTICE  AND  SHOULD  NOT  BE CONSTRUED AS A COMMITMENT BY DIGITAL
!	EQUIPMENT CORPORATION.
!
!	DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR  RELIABILITY  OF
!	ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
!
! FACILITY:    DIU (Data Interchange Utility for TOPS-20)
!
! ABSTRACT:    Process a DIU request block, either in slave or immediate 
!              mode.
!
! ENVIRONMENT: TOPS-20 V6.1          RMS V3 
!              BLISS-36 V4           XPORT
!
! AUTHOR:      Rick Fricchione                 CREATION DATE: 22-Oct-1984
! HISTORY:     
!  273  Make Do$Delete release its jfn with DRJ=0 and $CLOSE.
!       Andy Puchrik 12-Aug-87  SPR 21656
!
!  270  Fix edit 266. Never set the destination RSZ to the destination MRS if
!       the destination MRS is zero.
!       Sandy Clemens  17-Jul-86
!
!  267  VMS doesn't support alternate keys with NODUPLICATES and CHANGES.
!       Sandy Clemens  10-Jul-86
!
!  266	If the destination file  is fixed or the  user specified truncation  of
!       records (the destination MRS smaller than the source RSZ) then use  the
!       destination MRS for the destination  RSZ; otherwise use the source  RSZ
!       as the destination RSZ.
!	Sandy Clemens  10-Jul-86
!
!  264  Make SUBMIT work by setting  stream  mode  on  source  and destination.
!       Copying of VMS variable to LCG  stream files was  CRLFs  over  data  in
!       DO$FILE_COPY.
!       Gregory A. Scott 9-Jul-86
!
!  263  FAL-10 gives us the "file not  found"  error  on  the  $SEARCH not  the
!       $PARSE.  Add defensive code in DO$RENAME.
!       Gregory A. Scott  8-Jul-86
!
!  255  Make pulling image files  from TOPS-10 systems work.   We have to  copy
!       from the -10 in TRA and write SEQ because the FAL-10 gives us 320  word
!       records(!).  If FAL-10 is  fixed later (to support  BFT and sending  us
!       512 word records) we can remove some rude code here.
!       Gregory A. Scott 5-Jun-86
!
!  253  Change CRX library to DIUCRX and ACTION to DIUACTION. 
!       Gregory A. Scott 1-Jul-86
!
!  252	Remove library of CONDIT.
!	Sandy Clemens  1-Jul-86
!
!  251	In DIUDO.B36: Remove code which defaults TOPS-10 to image mode.  If the
!	user doensn't type /IMAGE, he doen't get image mode.
!	Sandy Clemens 30-Jun-86
!
!  250  Remove some of the strange workarounds for TOPS-10 now that I have  RMS
!       working a little better.
!       Gregory A. Scott 27-Jun-86
!
!  247	Handle LIBOL RECORDING MODE IS BINARY files (/LIBOL:n).
!	Sandy Clemens
!
!  244  In routine DO$COPY, set MRS before  the $PARSE/$SEARCH only if the  MRS
!       is not currently set; don't override existing value.
!       Sandy Clemens  26-Jun-86
!
!  243	Correct some of the problems in pulling image files from TOPS-10.
!	Sandy Clemens  24-Jun-86
!
!  240  Code at the end  of DO$COPY was overly  complicated.  Get around  (yet)
!       another bug in RMS by treating the RSA pointer as an ASCIZ string  (RSL
!       not filled in right if a PPN-style file spec is returned by a  remote).
!       Gregory A. Scott 19-Jun-86
!
!  237  Set the source and destination ostypes up before calling  DO$SETUP_COPY
!       in DO$SUBMIT;  new  routine  DO$OSTYPE_SETUP does  this.   This  caused
!       random "protection violation"  failures on PRINT  and SUBMIT  commands.
!       Also make DIU$SETUP_COPY not  give this same  message when a  "unknown"
!       operating system is discovered (in my case I was  trying to copy a file
!       to RSTS/E); just do nothing special and hope that it will work since it
!       is probably ASCII data.
!       Gregory A. Scott 19-Jun-86
!
!  236  Change library of DIXLIB to DIUDIX.
!       Sandy Clemens  19-Jun-86
!
!  235	Change library of RMSUSR to RMSINT.  Add call to DIU$CONV_STATS.
!	Sandy Clemens  18-Jun-86
!
!  231  Always set the source file MRS before the $PARSE/$SEARCH in DO$COPY.
!	This is necessary because the $SEARCH tries to return the RFM, and if
!	the MRS is zero, the RFM may be set wrong.  Before doing the $OPEN on
!	the source file, if the file is a TOPS-10/20 system then set the byte
!	size of the file (so that FFF $OPENs always work!).  Also set the TYP
!	block class field if the file is local.  (This will fail if the file is
!	remote!).  Then, after the $OPEN, call S$IFRMS (for local files only)
!	and if the file is an RMS file, then set the TYP class to zero (because
!	otherwise the $CONNECT will fail).  In DO$FILE_COPY, for the first
!	record ONLY (instead of for each record), read the last character and
!	see if the record is terminated by <CR>, <LF> or <FF>.  If not, then
!	set a flag which indicates to add <CRLF> for each record.  Also, if the
!	crlf is added (for EACH record), then increment the record size ONLY
!	ONCE!  It was getting incremented on EACH operation!
!	Sandy Clemens  16-Jun-86
!
!  230  Make remote renames work.  That ugly code introduced by 225  must  stay
!       forever.  Make DO$CONFIRM take source and dest FABs  instead  of  RABs,
!       fix several bugs in it.
!       Gregory A. Scott 12-Jun-86
!
!  227  Initialize src_usage_typ and dst_usage_typ before processing COPY or
!       APPEND.
!       Sandy Clemens  11-Jun-86
!
!  226	Always setting the class field in the TYP block (see edit 224) will not
!	work in all cases,  because if the  file is actually  an RMS file,  the
!	$CONNECT code will get  confused by the class  value in the TYP  block.
!	$OPEN checks for a prologue  and knows if the  file is actually an  RMS
!	file, but $CONNECT doesn't necessarily have the prologue to look at and
!	returns  RMS$_IAL  (Invalid  Access  List).   Therefore,  DIU  has   to
!	determine whether or not the file is an RMS file on a $OPEN (since  RMS
!	doesn't tell you) by checking the record format.  RMS files NEVER  have
!	record format of STM, LSA or UDF, so if one of those record formats  is
!	encountered (after the $OPEN)  then we can set  the class field in  the
!	TYP block.
!	Sandy Clemens  10-Jun-86
!
!  225  Make local RENAMEs work by moving $PARSE inside the  loop  looking  for
!       files - its a hack because of TOPS-20 bug.  If/when this bug is  fixed,
!       remove code with [225] in comments.  RMS can't be expected to know what
!       we are up to, that is why the workaround is here.
!       Gregory A. Scott  9-Jun-86
!
!  224  Change all of the DIU$xxx routine  names to be DO$xxx.  Remove  S$IFRMS
!       which would only work if  the file is local.   This was used to  decide
!       whether or not to set the type block class field.  Now, always set  it,
!       since it won't  hurt anything if  the file is  an RMS file,  and it  is
!       needed for a non-RMS file.   Also, add the code  to set the type  block
!       class field for the destination files on an append, since we do a $OPEN
!       rather than a $CREATE we'll need this information and it doesn't appear
!       to get  supplied to  us by  RMS.  Never  set the  block mode  flag  for
!       TOPS-10 files if the user already specified /STREAM.
!       Sandy Clemens  9-Jun-86
!
!  223  RENAME shouldn't look for multiple sets of input files.
!       Gregory A. Scott 7-Jun-86
!
!  221	Make APPEND command  work.  Remove routine  DIU$APPEND and have  APPEND
!       use DIU$COPY instead.  Make DIU$COPY work for APPEND!  Pass the request
!       function code to  DO$SETUP_COPY so  that we can  $OPEN the  destination
!       file for append rather than $CREATE it.  In DO$$LOAD_BLOCKS, fix bug in
!       $$RMS_MASK macro and remove tags which we don't use there.  Set up  for
!       block mode to TOPS-10.  General cleanup.
!       Sandy Clemens  6-Jun-86
!
!  212  Make the default record access mode (RAC) be TRA rather than BFT.
!       General cleanup.
!       Sandy Clemens  30-May-86
!
!  211  Make SUBMIT write a stream file if it is going to TOPS-10 or TOPS-20.
!       General cleanup.
!       Sandy Clemens/Gregory A. Scott  29-May-86
!
!  206  Remove DIU$LIST code, replace it with DIU$DIRECTORY in DIUDIR.  Put  in
!       defensive  code  to   prevent  /STREAM:CR  and   /STREAM:LF  and   /VFC
!       destination record formats on TOPS-10/20 systems.
!       Sandy Clemens/Gregory A. Scott 27-May-86
!
!  201  Make COPY with wildcarded local filespec work.  This worked already for
!       remote filespecs but there appears to be a bug in RMS causing different
!       behavior on the local system.  If at some point RMS changes, this new
!       code should be removed.  Search for [201] to find the work-around code!
!       Sandy Clemens  22-May-86
!
!  177  Call S$BREATHE here and there to  allow  interactive  COPY  commands to
!       work properly if we are (yet) the spooler.
!       Gregory A. Scott 22-May-86
!
!  175  Make src_dixtype and dst_dixtype LOCAL to DIU$COPY and change all other
!       references to them be references to src_ostype and dst_ostype.  Set up
!       line sequence numbers in the dst_rab correctly for LSA files.  Don't
!       write extra CRLFs into LSA destination record buffer.  Comment out code
!       for FAB$V_CR on TOPS-10/20.  It's not supported!!  Terminate stream
!       files CORRECTLY.  In DIU$KEY_ACTION change OWN variables to be LOCAL.
!       Sandy Clemens  20-May-86
!
!  173  Use routine S$IFRMS to check to see if a file is an RMS file.   Delete
!       library TOPS20, since it is no longer needed.
!       Gregory A. Scott 20-May-86
!
!  170  Various problems with releasing dynamic memory have been  fixed.   New
!       routine DO$FREE_MEMORY now does it right.  Rename CFMFILE back to  its
!       origional name and clean up global storage.
!       Gregory A. Scott 19-May-86
!
!  163  Dot bug in CFMFILE was causing the wrong message to be printed.
!       Gregory A. Scott 15-May-86
!
!  162  Initialize src_usage_typ and  dst_usage_typ so  that datatype  (usage)
!       conflicts are not issued constantly.
!       Sandy Clemens  14-May-86
!
!  157  Remove external reference to REQBLK.  Use passed REQUEST instead.  Add
!       parameter REQUEST  to DIU$KEY_ACTION  routine.  When  copying  indexed
!       files to a sys_8bit system, set record access to RAB$K_TRA  (RAB$K_KEY
!       does not work!).
!       Sandy Clemens 14-May-86
!
!  156  Remove references to DIU$B_SOURCE_USAGE_TYP and DIU$B_DEST_USAGE_TYP,
!       since they are not needed and not set by DIUC20 any more.
!       Gregory A. Scott 13-May-86
!
!  155  In DIUDO.B36:  Remove external  of L$NEW_REQUEST  (not used  anymore).
!       Don't call DIU$DEF_TRANS unless there is a source description!  Set up
!       TYP class for TOPS-10  source files as well  as TOPS-20 source  files.
!       Make /IMAGE work (between TOPS-10/20  systems only).  Remove check  of
!       ISAM file switches (parser  does this now!).  In DIU.R36: add  message
!       DIU$_IMAGE_INVALID.
!       Sandy Clemens  12-May-86
!
!  154  Output the number of  requeues in the log  file after request  started.
!       Since cretinous RMS20  doesn't follow  standard BLISS  error codes,  we
!       have to convert his errors to something we can return from DIU$DO.
!       Gregory A. Scott 12-May-86
!
!  153  In DIUDO.B36  remove SFLAGS  and  DFLAGS (they  are bogus  for  queued
!       requests!).  Add  check of  FDB to  determine if  the source  file  is
!       NONRMS,  in  which  case  set  the  byte  size  and  TYP  block  class
!       accordingly.  Remove code which  does switch checking  -- this is  now
!       done by  the command  parser in  DIUC20.  The  parser now  copies  the
!       source record descirption file name  into the destination if the  dest
!       doesn't (yet) exist, so we can remove DIU$COPY_DESCRIPTION.  Clean  up
!       DO$ATTRIBUTE_COPY.  Any initial  defaults are  now set up  in the  RMS
!       block initializations.  Record  access of RAB$K_TRA  doesn't work  for
!       source  file  organization  of  FAB$K_REL;  change  record  acces   to
!       RAB$K_SEQ if the source file is relative.  Don't check for key  fields
!       being byte aligned -- the routines which build the record  description
!       trees already  do this  for  each field.
!       Sandy Clemens  12-May-86
!
!  147  Open up the log file using L$UINIT routine rather than doing it here.
!       Gregory A. Scott 8-May-86
!
!  145  Set up the record count correctly for RMS RELATIVE files.  If the user
!       specified a maximum record size then use it if it's valid  and  signal
!       if it's too small.  When creating RMS RELATIVE and RMS INDEXED  files,
!       set RAC to KEY before the $CREATE.
!       Sandy Clemens 7-May-86
!
!  144  Call to DIU$MESSAGE from here shouldn't write to the system  log  file
!       if we are (yet) the spooler.
!       Gregory A. Scott 7-May-86
!
!  136  Make keys work for indexed files.  Change DIU$UPPERCASE to $STR_FORMAT
!       and delete DIU$UPPERCASE routine.  Add support for key option switches
!       which was missing from DIU$KEY_ACTION.
!       Sandy Clemens 1-May-86
!
!  135  Give request started message before doing anything else, replace macros
!       defined in DIU.R36 that just expanded into text for FAO output with the
!       actual text.
!       Gregory A. Scott 1-May-86
!
!  131  Remove external of  diudbg, which  wasn't referenced and  is no  longer
!       used.
!       Gregory A. Scott 28-Apr-86
!
!  126  Routine E$FILES doesn't return a value but the EXTERNAL ROUTINE thought
!       it did.
!       Gregory A. Scott 26-Apr-86
!
!  125  Output CRLF, hyphen, tab before filenames so they fit within  80
!       columns in log files.  Minor changes due to changes in $MSG_FAO.
!       Gregory A. Scott
!
!  123  Change routine R$$LIST to be E$FILES, only passing 2 arguments.
!       Gregory A. Scott 23-Apr-86
!
!  107  Clean up all routines from noisy comments, unused str_inits.  Make
!       DIU$DELETE and DIU$RENAME do wild cards.
!       Andy Puchrik    2-Apr-86
!
!  103  Always free the memory from dynamically allocated XABKEY structures
!       when the request is finished.  Check for wildcard source filespec
!       and multiple file output.
!       Andy Puchrik    31-Mar-86
!
!  101  Clean up routine DIU$KEY_ACTION.  PRODUCE_FQN zaps the string
!       passed it so pass it a temp copy of the key token.  Make key
!       string in req block all uppercase so it will match the name
!       string in the record description tree (always in uppercase!);
!       add routine DIU$UPPERCASE to do this.  In DO$ATTRIBUTE_COPY
!       don't copy src XABKEYs to dst if the dst XABKEYs already
!       exist!  Be more careful about when to add/remove CR/LF to the
!       dst buffer.  Only figure "image_bytes" for non-LCG systems.
!       Fix image_bytes formula so VAX won't return invalid RSZ error.
!       General cleanup.
!       Sandy Clemens   26-Mar-86
!
!   75  Add DIU$KEY_ACTION routine to parse key command text stored in
!       request block.
!       Sandy Clemens   19-Mar-86
!
!   74  Figure image mode MRS correctly based on what DAP does.
!       Sandy Clemens   18-Mar-86
!
!   73  Make all /WARNINGS and /USAGE information be stored in the request
!       block structure (not in global flags -- this won't work for queued
!       requests).  Get rid of "need_usage" (again?).
!       Sandy Clemens   4-Mar-86
!
!   72  Define WARNINGS_COUNT and if /WARNINGS:n was not specified by the
!       user, then set WARNINGS_COUNT to the default which is 1.  Remove
!       WARNING_MAX.  Remove some debugging stuff.
!       Sandy Clemens   3-Mar-86
!
!   71  Always set the byte size to 36 for fortran binary files.  Set the
!       destination maximum record size to 625 as a temporary workaround
!       for a RMS bug which causes problems copying files to a VAX.
!       Sandy Clemens   25-Feb-86
!
!   70  Restructure DIU$COPY so that the $PARSE of the dst file, the call to
!       DIU$LOAD_TRANS, and, therefore, the figuring of the source TYP$H_CLASS
!       and FAB$V_BSZ, are all done before the $OPEN of the source.  This info
!       is needed for the $OPEN.  Remove setting the dst SYNCHK bit:  it causes
!       the config XAB not to be filled in and so we can't get the dst op sys
!       type.  Force RMS to usae image mode to copy to VAX or PRO w/transform
!       (since DIL puts the data into VAX/PRO image mode).  Clean up adjustment
!       of MRS/RSZ.  If dst file is NONRMS make sure src is NONRMS & there's no
!       transform.  Clear dest buffer after $PUT.  Clean up DO$ATTRIBUTE_COPY
!       and make it smarter about defaults.
!       Sandy Clemens  25-Feb-86
!
!   65  Use global usage flags to set TYP$H_CLASS for src & dst before $OPENs.
!       Remove passing src_buf and dst_buf to DO$SETUP_COPY.  Remove 2nd call
!       to $RAB_INIT in DO$SETUP_COPY since there is one in DO$INIT_BLOCKS.
!       Check global usage flags to determine what to pass to DIU$LOAD_TRANS
!       for usage types;  after call to DIU$LOAD_TRANS reset TYP$H_CLASS in
!       case a new usage was found.  Disallow copying ISAM file to anything
!       but another ISAM w/out transformation.  Clean up DO$HANDLER and delete
!       large commented out section.
!       Sandy Clemens  12-Feb-86
!
!   64  Add checking of GLOBAL patpar_warn which is a flag that gets set
!       if the DIU$_PATPAR informational condition is seen, and which is
!       cleared when either DIU$_PARDES error condition or DIU$_PARTRA
!       error condition is seen.
!       Sandy Clemens  15-Jan-86
!
!   63  Remove comments in DO$SETUP_COPY which adjust dst_fab[FAB$H_MRS]
!       after transform execution.  Correct the format of the calls to
!       DIU$PARSE_TRANSFORM and DIU$PARSE_DESCRIPTION routines.
!       FILE: DIUDO.B36
!       Andy Puchrik  9-Jan-86
!
!   56  Remove code in DO$COPY_FILE which always defaults copy-with-conversion
!       default to IMAGE mode.  Remove TOPS10 conditional from the code which
!       sets the dst_fab[FAB$V_SUP] bit in DO$INIT_BLOCKS.  In DO$SETUP_COPY
!       increase dst_fab[FAB$H_MRS] by 2 to make room for CR,LF.  In record
!       mode transfers (with NO conversion) point the dst_rab[RAB$A_RBF] at the
!       dst_rab[RAB$A_UBF] NOT at the src_rab[RAB$A_RBF] because making the
!       src and dst the same will cause conficts (reading and writing to/from
!       the same place!!).  Clean up the code which releases the dst JFN and
!       $CLOSES the dst_fab in DO$HANDLER.
!       Sandy Clemens   3-Dec-85
!
!    54   Uncomment code in DO$SETUP_COPY to check for destination file
!         being disk (MDI) or remote file (in setup for block mode transfer).
!         FILE:  DIUDO.B36.
!         Sandy Clemens  14-Nov-85
!
!    53   In routine DO$COPY_FILE do NOT reset the byte size in the RABs.
!         Also, make sure to copy the source record buffer to the destination
!         record buffer.
!         Sandy Clemens 13-Nov-85
!
!    52   Make error text NOT display passwords.
!         Sandy Clemens  12-Nov-85
!
!     51  Fix stream LF with CR.
!         Andy Nourse   7-Nov-85
!
!     45  Make DO$HANDLER return a status even if it doesn't have a source
!         FAB.  If this is not done, anything that signals without a source
!         FAB set returns 0, which causes the request to be queued even on
!         a non-recoverable error.
!         Sandy Clemens   21-Oct-85
!
!     43  Have DO$HANDLER return RMS error as routine value rather than
!         DIU$_RMS_ERROR, since we need the actual RMS status to make the
!         queue/noqueue decision.
!         Sandy Clemens   16-Oct-85
!
!     40  Put the REQUIRE/LIBRARY of 'TOPS20' into a TOPS-20 only
!         conditional.
!         Sandy Clemens  7-Oct-85
!
! v01-27     Andy Nourse  28-Aug-85
!            Handle NOT bits as well as bits (for /OLD)
!
! v01-24     Andy Nourse  18-Jul-85
!            Put in /WARNINGS and /KEY switches, description and
!            transform processing, and fix DO$BYPASS for slave jobs. 
!
! V01-01     RDF0002         Rick Fricchione               5-Jan-1985
!            Set up DO$ATTRIBUTE_COPY routine so that it creates the
!            proper number of key XAB's and area allocation XAB's for
!            RMS indexed files.  
!
! V01-00     RDF0001         Rick Fricchione               22-Oct-1984
!            DIU version.  Rewrite from FTS DO.BLI. Changes to handle
!            new request block formats, RMS V3 and DIU specifics.
!
!--
%SBTTL 'Library files'

LIBRARY 'BLI:XPORT';                    ! XPORT
LIBRARY 'FAO';                          ! FAO formatting
LIBRARY 'DIU';                          ! DIU data structures
LIBRARY 'RMSINT';                       ! RMS interface
LIBRARY 'DIUCRX';                       ! CRX data structures
LIBRARY 'MONSYM';                       ! Tops-20 monitor symbols
REQUIRE 'JSYSDEF';                      ! JSYS definitions
REQUIRE 'DIUPATPORTAL';                 ! Descr Parser stuff
LIBRARY 'DIUTLB';                       ! Short names 
LIBRARY 'DIUMLB';                       ! Short names 

UNDECLARE STS$K_SEVERE,                 ! these are defined in DIUDIX also
          STS$K_ERROR,
          STS$K_WARNING,
          STS$K_SUCCESS,
          STS$K_INFO,
          SS$_NORMAL;

LIBRARY 'DIUDIX';                       ! DIX definitions
LIBRARY 'DIUACTION';                    ! Short names
%SBTTL 'Forward routines'

FORWARD ROUTINE
    DIU$DO,                             ! Process DIU request block
    DO$COPY,                            ! Copy a file or files
    DO$DELETE,                          ! Delete a file or files
    DO$RENAME,                          ! Rename a file 
    DO$SUBMIT,                          ! Submit a command file
    DO$CONFIRM : NOVALUE,               ! Type confirmation msg
    DO$FREE_MEMORY : NOVALUE,           ! Free dynamic memory
    DO$HANDLER,                         ! Condition handler
    DO$BYPASS,                          ! Is error bypassable
    DO$INIT_BLOCKS : NOVALUE,           ! Init RMS blocks
    DO$LOAD_BLOCKS : NOVALUE,           ! Load RMS blocks
    DO$OSTYPE_SETUP : NOVALUE,          ! Setup operating system types
    DO$SETUP_COPY : NOVALUE,            ! Setup copy operation
    DO$ATTRIBUTE_COPY : NOVALUE,        ! Copy file attributes
    DO$FILE_COPY,                       ! Copy records in file
    DO$KEY_ACTION : NOVALUE;            ! Process key info
%SBTTL 'Literals and Macros'

%IF NOT %DECLARED ($CHCRT) %THEN LITERAL $CHCRT = %O'15' ; %FI
%IF NOT %DECLARED ($CHLFD) %THEN LITERAL $CHLFD = %O'12' ; %FI
%IF NOT %DECLARED ($CHFFD) %THEN LITERAL $CHFFD = %O'14' ; %FI

LITERAL
     dap$k_buffer_size          = 8192, ! defined also in DAP.REQ
     bytes_per_word             = 4,
     dap$k_buffer_size_in_words
        = (dap$k_buffer_size + bytes_per_word - 1) / bytes_per_word;

LITERAL
    %IF %SWITCHES(TOPS20)
    %THEN
     our_ostype                 = XAB$K_TOPS20;
    %ELSE
     our_ostype                 = XAB$K_TOPS10;
    %FI

MACRO
      source_buffer    = request[DIU$T_SOURCE_FILESPEC]%,        
      source_length    = request[DIU$H_SOURCE_FILESPEC]%,        
      dest_buffer      = request[DIU$T_DESTINATION_FILESPEC]%,   
      dest_length      = request[DIU$H_DESTINATION_FILESPEC]%;
%SBTTL 'Module static storage'

OWN 
      bits_per_record : INITIAL(0),     ! will be set by DO$LOAD_TRANS
      src_ostype,                       ! src operating system type (RMS code)
      dst_ostype,                       ! dst operating system type (RMS code)
      src_dixtype,                      ! src dix operating system type
      dst_dixtype,                      ! dst dix operating system type
      src_usage_typ,                    ! source file usage type
      dst_usage_typ,                    ! destination file usage type

      block_mode_flag,                  ! indicates block mode transfer if ON

      src_fab : VOLATILE $FAB_DECL,     ! source RMS blocks
      src_rab : VOLATILE $RAB_DECL,
      src_typ : $TYP_DECL,
      src_nam : $NAM_DECL,
      srcsum_xabsum : $XABSUM_DECL,
      srccfg_xabcfg : $XABCFG_DECL,
      srcdat_xabdat : $XABDAT_DECL,

      dst_fab : VOLATILE $FAB_DECL,     ! destination RMS blocks
      dst_rab : VOLATILE $RAB_DECL,
      dst_typ : $TYP_DECL,
      dst_nam : $NAM_DECL,
      dstsum_xabsum : $XABSUM_DECL,
      dstcfg_xabcfg : $XABCFG_DECL,
      dstdat_xabdat : $XABDAT_DECL,

      sfnm : VECTOR[CH$ALLOCATION(NAM$k_MAXRSS)], ! ASCIZ source
      dfnm : VECTOR[CH$ALLOCATION(NAM$k_MAXRSS)], ! ASCIZ destination

      sesa : VECTOR[CH$ALLOCATION(NAM$k_MAXRSS)], ! Expanded 
      srsa : VECTOR[CH$ALLOCATION(NAM$k_MAXRSS)], ! Resultant

      desa : VECTOR[CH$ALLOCATION(NAM$k_MAXRSS)], ! Expanded
      drsa : VECTOR[CH$ALLOCATION(NAM$k_MAXRSS)], ! Resultant

      sbuf : VECTOR[DAP$K_BUFFER_SIZE_IN_WORDS],  ! Source record buffer
      dbuf : VECTOR[DAP$K_BUFFER_SIZE_IN_WORDS],  ! Destination record buffer
                                                                        
      rtrans,                           ! Transform for request
      sdescr,                           ! Source file record description
      ddescr,                           ! Dest file record description
      doflags: BITVECTOR[36];           ! Flags 

MACRO
      outfile_open     = doflags[0] %,  ! Output file is open
      appending        = doflags[2] %,  ! Appending/concatenating files
      multiple         = doflags[3] %;  ! Multiple output files

GLOBAL warnings_count;                  ! Max warnings to give per field 
%SBTTL 'Externals'

EXTERNAL ROUTINE
    S$IFRMS,                            ! Check file class bit (RMS or not)
    E$FILES : NOVALUE,                  ! Extract filespec 
    MOVE_WITHOUT_PASSWORD,              ! copy filspc, chng pswd to "password"
    R$ERRMSG,                           ! RMS message from STS
    RMS$SIGNAL,                         ! Convert error to SIGNAL
    DIU$MESSAGE,                        ! Display error message
    DIU$ERRMSG,                         ! Create an error message
    DIU$ABORT,                          ! DIU error handler
    L$UINIT : NOVALUE,                  ! Open user log file
    LJ$ULOG : NOVALUE,                  ! write condition to user log file
    LJ$UTXT : NOVALUE,                  ! write text to user log file
    IP_STATUS,                          ! Send status message to (yet) spooler
    S$BREATHE : NOVALUE,                ! Allow spooler to take a breath
    S$MOUNTEM : NOVALUE,                ! mount all local structures needed
    S$CRIF : NOVALUE,                   ! do a <CR> if not a LM
    DIU$DIRECTORY,                      ! Do a directory
    DIU$PARSE_DESCRIPTION,              ! parse record description tree
    DIU$PARSE_TRANSFORM,                ! parse transform
    DIU$DEF_TRANS,                      ! default transform
    DIU$LOAD_TRANS,                     ! load transform
    DIU$EXECUTE_TRANS,                  ! execute transform
    DIU$DEL_TRANS_LIST,                 ! free memory from transform list
    FREE_RECORD,                        ! free memory from record descr tree
    DIU$CSR;                            ! generate conversion statistics report

EXTERNAL patpar_warn,                   ! flags warnings from pat parser
         tty : $XPO_IOB (),             ! IOB for user's terminal
         interactive;                   ! Flag if interactive or spooler subjob
%SBTTL 'Request Block Format'
!++
!   HOW IT WORKS:
!
!   The majority of the request block is fairly straightforward, and the
!   routines contained in this module process them in the usual manner.
!   However, the format of the filespecs in the request block is of concern 
!   to the routines, as they need to decipher this format in order to read 
!   files and attributes from the request block.  Each of the routines issues
!   basically the same set of CH$ calls in order to process this filespec
!   list.
!
!   The format of a request block filespec looks this.
!
!  +-----+-----+-----+------+-----+----------+-----+-----+------+------+------+
!  | gbl | gbl | gbl | $ETG | fil | filespec | tag | tag | tag  | $ETG | $NUL |
!  | tag : len | val +------+ len +----------+ len | id  | val  +------+------+
!  +-----+-----+-----+      +-----+          +------+----+------+      
!  <--- repeating--->       <-------------- repeating ---------------->
!
!   gbl_tag    -     a global attribute id which will be propogated throughout
!                    all succeeding filespecs.  This corresponds to a switch
!                    attached to a verb.  This is a one byte id which indicates
!                    which attribute is being set.
!
!   gbl_len    -     All attributes values are stored as ASCII text.  This is 
!                    a character whose ordinal value represents the length of
!                    the characters in the value.
!   
!   gbl_val    -     ASCII characters of "gbl_len" size.  This represents the
!                    value to drop in an RMS field, or otherwise process.
!
!   $ETG       -     An one byte "End-of-tag" indicator that tells us there
!                    are no more global tags to process.  The above three
!                    global tag fields can repeat until this is seen.
!
!   file_len   -     A one byte character whose ordinal value represents the 
!                    length of the filespec which follows in characters.
!
!   filespec   -     The filespec to be processed.  Possibly wildcarded, or
!                    a logical name.  This is "file_len" characters in size.
!
!   tag_id     -     A one byte attribute id used to identify which RMS field
!                    is to be modified or what the following field is.
!
!   tag_len    -     A one byte character whose ordinal value represents the
!                    length of the tag value to come in characters.
!
!   tag_val    -     The actual value contained in "tag_len" characters.
!
!   $ETG       -     An "End-of-tags" indicator, telling us that no more tags
!                    are attached to this filespec.  Until this is reached
!                    the above tag sequence can repeat.
!
!   $NUL       -     A null character which indicates the end of the entire
!                    buffer.
!
!   * Note that all numerical data is stored as ASCII characters.  For example
!     in order to make CH$ functions do the right thing, we store the MRS tag
!     value 123 as the characters "123" and not as a binary number embedded in
!     the string as on VMS.
!
!   * Note that routines must expect the contents of a filespec to be 
!     wildcarded and must have an inner loop to process the results of
!     $SEARCH as well as an outer loop which processes all occurrences of
!     filespecs in the request block field.
!--
%SBTTL 'Routine DIU$DO - Process a DIU request'

GLOBAL ROUTINE DIU$DO (req : REF $DIU_BLOCK) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!       Process a DIU request.  This routine will look at a DIU request
!       block and dispatch to the routine which processes the function
!       specified.  
!
! FORMAL PARAMETERS:
!
!       req : Address of a DIU request block
!
! COMPLETION CODES:
!
!       Success or error code
!
! SIDE EFFECTS:
!
!       Request will have been completed (or failed)
!
!--
LOCAL retcode,
      status;

ENABLE DIU$ABORT;

$TRACE(DIU$DO);

doflags = 0;                            ! Initialize flags

! Open the user log file, or not if /NOLOG_FILE was specified.

L$UINIT(.req);                          ! Pry it open

! If running as a slave, detached job, notify master that we've started,
! and connect to the specified directory.

IF NOT .interactive                    
THEN BEGIN
     SIGNAL(DIU$_REQUEST_STARTED);      ! Give request started message
     IF .req[DIU$G_REQUEUE_COUNT] NEQ 0 ! Any requeues?
     THEN SIGNAL(DIU$_REQUEUE_COUNT,1,.req[DIU$G_REQUEUE_COUNT],0); ! Yes
     S$MOUNTEM (.req);                  ! connect to proper directory, or die
     END;

! If there are no filespecs, signal the error.

IF (.req[DIU$H_SOURCE_FILESPEC] EQL 0)
   AND (.req[DIU$H_DESTINATION_FILESPEC] EQL 0)
THEN SIGNAL(DIU$_INV_STR_LENGTH);

! If we have a source record description, then parse it and build the src
! record description tree.  If we also a destination, parse it and build
! the tree for it.  (If a destination description wasn't specified by the
! user but the source was, then the command parser gives copies the source
! descr file name into the dest descr file name, so we don't have to check
! for that here!)  Next, if a transform was specified, parse it and build the
! internal structure.  If a transform wasn't specified, generate a default
! transform (move matching).  If the source record description tree wasn't
! specified, but the transform or destination record description was, then the
! parser tells the user that the source descr is missing (UNLESS the dest is
! an indexed file, in which case we need the dst description to find the KEYs).
! Since the parser now checks for these cases, we don't have to do that here.

IF .req[DIU$H_SOURCE_DESCRIPTION] NEQ 0 ! if src description given
THEN BEGIN
     LOCAL
          retcode,
          srcdesc: $STR_DESCRIPTOR(                                            
                       STRING = (.req[DIU$H_SOURCE_DESCRIPTION],
                                 CH$PTR (req[DIU$T_SOURCE_DESCRIPTION])));

     retcode = DIU$PARSE_DESCRIPTION (srcdesc, sdescr);
     IF .patpar_warn THEN SIGNAL (DIU$_PARDES);
     END;

IF .req[DIU$H_DESTINATION_DESCRIPTION] NEQ 0    ! if dst decr given
THEN BEGIN
     LOCAL
          retcode,
          dstdesc: $STR_DESCRIPTOR(
                       STRING = (.req[DIU$H_DESTINATION_DESCRIPTION],
                                 CH$PTR (req[DIU$T_DESTINATION_DESCRIPTION])
                                 ));
     retcode = DIU$PARSE_DESCRIPTION (dstdesc, ddescr);
     IF .patpar_warn THEN SIGNAL (DIU$_PARDES);
     END;

IF .req[DIU$H_TRANSFORM] NEQ 0          ! if a transform was given by user
THEN BEGIN
     LOCAL
          retcode,
          trdesc: $STR_DESCRIPTOR(
                      STRING = (.req[DIU$H_TRANSFORM],
                                CH$PTR (req[DIU$T_TRANSFORM])));
     retcode = DIU$PARSE_TRANSFORM (trdesc,
                                    .sdescr,
                                    .ddescr,
                                    rtrans);
     IF .patpar_warn THEN SIGNAL (DIU$_PARTRA);
     END
ELSE
     IF .req[DIU$H_SOURCE_DESCRIPTION] NEQ 0    ! if src description given
     THEN DIU$DEF_TRANS (sdescr,    ! generate default transform
                         ddescr,
                         rtrans);

! Set warnings_count (maximum warnings per field) for use when
!  executing transforms...

warnings_count = .req[DIU$H_WARNING_MAX];


! Done with setup, now dispatch to the appropriate action routine
! for the function code given.

status = (CASE .req[DIU$H_FUNCTION] FROM DIU$K_MIN_FUNCTION
                             TO DIU$K_MAX_FUNCTION OF
          SET
          [DIU$K_COPY]      : DO$COPY(.req);
          [DIU$K_APPEND]    : DO$COPY(.req);
          [DIU$K_DELETE]    : DO$DELETE(.req);
          [DIU$K_RENAME]    : DO$RENAME(.req);
          [DIU$K_PRINT]     : DO$SUBMIT(.req);
          [DIU$K_SUBMIT]    : DO$SUBMIT(.req);
          [DIU$K_DIRECTORY] : DIU$DIRECTORY(.req);
          [OUTRANGE]        : SIGNAL(DIU$_INV_FUN_CODE);
          TES);

! Free dynamic memory acquired earlier.

DO$FREE_MEMORY();

! Since cretinous RMS20 doesn't follow standard BLISS error codes, we have to
! convert his errors to something we can understand elsewhere.

retcode = (SELECTONE .status OF
           SET
           [RMS$K_ERR_MIN
            TO RMS$K_ERR_MAX] : FALSE;          ! Unsuccessful RMS code
           [RMS$K_SUC_MIN
            TO RMS$K_SUC_MAX] : DIU$_NORMAL;    ! Successful RMS code
           [OTHERWISE] : IF .status             ! Other codes
                         THEN TRUE
                         ELSE FALSE;
           TES);

IF NOT .interactive                     ! If this is slave job
   AND .retcode                         ! and it was successful
THEN SIGNAL(DIU$_REQUEST_COMPLETED);    ! then log it to user and system logs

! Return status which tells the caller:
!  If slave:  do we need to requeue the request or not
!  If interactive:  do we need to queue the request or not

RETURN .retcode;

END;
%SBTTL 'DO$FREE_MEMORY - Free Dynamic Memory'

ROUTINE DO$FREE_MEMORY : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Free memory acquired for transform, descriptions, and key xabs.
!
! IMPLICIT INPUTS:
!
!       rtrans: pointer to transfor strcture or 0
!       sdescr: pointer to description strcture or 0
!       ddescr: pointer to destination description or 0
!       dstdat_xabdat[XAB$A_NXT]: pointer to key xabs or 0
!
! SIDE EFFECTS:
!
!       Dynamic memory is freed up
!
!--

LOCAL axab : REF $xabkey_decl,
      nxtxab : REF $xabkey_decl;

IF .rtrans NEQ 0                        ! Any transform storage to free
THEN BEGIN                              ! Yes, free it
     DIU$DEL_TRANS_LIST(.rtrans);
     rtrans = 0;
     END;

IF .sdescr NEQ 0                        ! Any source description stg?
THEN BEGIN                              ! Yes free it
     FREE_RECORD(.sdescr);
     sdescr = 0;
     END;

IF .ddescr NEQ 0                        ! Any source description stg?
THEN BEGIN                              ! Yes, free it
     FREE_RECORD(.ddescr);
     ddescr = 0;
     END;

! Free dynamically allocated XABKEY structures.

nxtxab = .dstdat_xabdat[XAB$A_NXT];     ! Point to first xab key or 0
WHILE .nxtxab NEQ 0                     ! While there is still a next XAB
DO BEGIN                                ! Free any XABKEY structures
   axab = .nxtxab[XAB$A_NXT];           ! Remember next xab
   $XPO_FREE_MEM (BINARY_DATA = (xab$k_keylen,  ! Thanks for the memory
                                 .nxtxab,
                                 FULLWORDS));
   nxtxab = .axab;                      ! Point to next xab
   END;
dstdat_xabdat[XAB$A_NXT] = 0;           ! Zero the pointer to xabkeys

END;                                    ! DO$FREE_MEMORY
%SBTTL 'DO$COPY - Execute A COPY or APPEND Request'

GLOBAL ROUTINE DO$COPY (request : REF $DIU_BLOCK) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Copy a file.  Always use RMS (is there any other way?!!).
!
! FORMAL PARAMETERS:
!
!       request -  Address of a DIU request block to be used in creating
!                  or initializing RMS data structures for COPY.
!--
LABEL process;

LOCAL eob,
      status,
      bio_flag : INITIAL (0),
      src,
      dest,
      src_len,
      dest_len,
      remaining,
      next_ptr,
      copy_count : INITIAL(0),
      current : $STR_DESCRIPTOR(),
      next_file,
      many_in : INITIAL(0),
      many_out : INITIAL(0),
      function_code,
      count : INITIAL(0);

ENABLE DO$HANDLER (src_fab, dst_fab, src_rab, dst_rab);

$TRACE(DO$COPY);

IF .request [DIU$H_FUNCTION] EQL DIU$K_APPEND   ! if we were called by APPEND
THEN appending = TRUE;                          ! set the appending bit

! Find the first file in the source buffer, if empty send our regrets...

eob = CH$PLUS (CH$PTR (source_buffer),
               .source_length);
src = CH$FIND_CH (.source_length,
                  CH$PTR (source_buffer),
                  $ETG);
IF CH$FAIL(.src)
THEN SIGNAL(DIU$_INV_STR_LENGTH);

! If we have more than one input file, then set the flag

remaining = CH$DIFF(.eob, .src);
next_file = CH$FIND_CH(.remaining, CH$PLUS(.src, 1), $ETG);
IF CH$A_RCHAR(next_file) NEQ $NUL 
THEN BEGIN
     many_in = TRUE;
     $TRACE('DO$COPY More than one input file seen');
     END;

! Find the beginning of the destination filespec

dest = CH$FIND_CH(.dest_length, CH$PTR(dest_buffer), $ETG);
dest_len = CH$A_RCHAR(dest);
dest = CH$PLUS(.dest,1);

DO$INIT_BLOCKS();                       ! Initialize the RMS blocks

IF .request [DIU$H_FUNCTION] EQL DIU$K_APPEND
THEN dst_fab [FAB$V_OFP] = FALSE;       ! use existing output file

DO BEGIN
     !
     ! Check all the filespecs until we have reached the end of the sources
     !

     src_len = CH$A_RCHAR(src);         ! Get the length of the filespec 
     src = CH$PLUS(.src, 1);            ! bump past length

     ! Load in source file and attributes 

     DO$LOAD_BLOCKS(src_rab, source_buffer, src, src_len, sfnm);

     ! Always give the MRS a value before the $PARSE/$SEARCH because if the MRS
     ! is not set, the RFM field may not get returned correctly by RMS.  If the
     ! file is a SIXBIT LIBOL file and the MRS is zero, then the RFM will be
     ! set to STM, which is wrong!

     IF .src_fab [FAB$H_MRS] EQL 0
     THEN src_fab [FAB$H_MRS] = DAP$K_BUFFER_SIZE;

     ! Turn off the source FAB BIO bit if it is on, because if the file is on a
     ! TOPS-10 system, the $PARSE will fail (with a DAP unsupported operation
     ! error) if BIO is ON.  Set flag to remember that BIO was on.  After the
     ! $PARSE, reset BIO in the source FAB.

     bio_flag = .src_fab[FAB$V_BIO];    ! Copy BIO flag
     src_fab[FAB$V_BIO] = FALSE;        ! Turn off BIO for the parse

     $PARSE(FAB = src_fab, ERR = RMS$SIGNAL);

     src_fab[FAB$V_BIO] = .bio_flag;    ! Reset BIO to what it used to be

     $TRACE('DO$COPY Parse of input file OK');

     $SEARCH(FAB = src_fab, ERR = RMS$SIGNAL);  ! Set up wildcarding context

     IF NOT (.src_nam[NAM$V_WILD_DIR]  OR       ! wildcarded input files?
             .src_nam[NAM$V_WILD_NAME] OR
             .src_nam[NAM$V_WILD_TYPE] OR
             .src_nam[NAM$V_WILD_VER])
     THEN src_fab[FAB$V_DRJ] = 0        ! we want to release this JFN
     ELSE BEGIN
          src_fab[FAB$V_DRJ] = 1;       ! keep the wild ones
          many_in = TRUE;               ! assume wildcard hits several files
          END;

     UNTIL .src_fab[FAB$H_STS] EQL RMS$_NMF DO
        BEGIN
process:  BEGIN

            IF NOT $RMS_STATUS_OK(src_fab)      ! did the $SEARCH go OK?
            THEN BEGIN
                 IF DO$BYPASS(src_fab)          ! if a bypassable error
                 THEN LEAVE process;            ! then exit block
                 SIGNAL(.src_fab[FAB$H_STS],    ! else signal error
                        .src_fab[FAB$H_STV],
                        src_fab);
                 END;

            $TRACE('DO$COPY $SEARCH found input file');

            ! If the dst file is not open and (due to RMS problem with local
            ! operations) either there are not multiple output files (yet!) or
            ! the dst is remote, then call $PARSE and establish the wildcard
            ! context.  For local files we don't want the $PARSE here except
            ! the first time through this code, (due to RMS problems!!)  but a
            ! call to $PARSE has been added after the $OPEN for the src file...

            IF (NOT .outfile_open
                AND (NOT .many_out OR .dst_fab[FAB$V_REMOTE]))  ! [201]
                ! never $parse the output filespec if appending since
                ! wildcards are not supported on append...
                AND (.request[DIU$H_FUNCTION] NEQ DIU$K_APPEND)
            THEN BEGIN
                 LOCAL dfnm_ptr;
                 ! Get dst file name for the $PARSE...
                 dfnm_ptr = CH$PTR(dfnm);
                 CH$FILL (0, NAM$K_MAXRSS, .dfnm_ptr);
                 CH$MOVE (.dest_len, .dest, .dfnm_ptr);
                 dfnm_ptr = CH$PLUS (.dfnm_ptr, .dest_len+1);
                 CH$WCHAR_A (0, dfnm_ptr);
                 dst_fab[FAB$A_FNA] = CH$PTR (dfnm);    ! dst name set up

                 $PARSE(FAB=dst_fab,ERR=RMS$SIGNAL);
                 $TRACE('DO$COPY $PARSE of output file OK');
                 IF (.dst_nam[NAM$V_WILD_DIR]  OR       ! mult output files?
                     .dst_nam[NAM$V_WILD_NAME] OR
                     .dst_nam[NAM$V_WILD_TYPE] OR
                     .dst_nam[NAM$V_WILD_VER])
                 THEN many_out = TRUE;                  ! set mult output flag
                 END;

            ! If mult outputs seen and the dst file is local then set DRJ bit
            ! (don't release JFN on close).  This code has been added due to a
            ! problem with local operations in RMS...

            IF (.many_out AND NOT .dst_fab[FAB$V_REMOTE])       ! [201]
            THEN dst_fab[FAB$V_DRJ] = 1                         ! [201]
            ELSE dst_fab[FAB$V_DRJ] = 0;                        ! [201]

            ! On concatenated inputs, go into append mode...

            IF .many_in AND (NOT .many_out) THEN appending = TRUE;

            DO$OSTYPE_SETUP();          ! Set up src and dst os types

            ! Load transform file if one was specified

            IF .rtrans NEQ 0            ! Was a transform was specified
            THEN BEGIN                  ! Yes, load it

                 ! initialize the usage types

                 src_usage_typ = unspec_typ;
                 dst_usage_typ = unspec_typ;

                 ! load the transform

                 bits_per_record = DIU$LOAD_TRANS (
                           .sdescr,             ! src record description tree
                           .src_rab[RAB$A_UBF],
                           .src_rab[RAB$H_USZ],
                           .src_dixtype,        ! source system type
                           .ddescr,             ! dst record description tree
                           .dst_rab[RAB$A_UBF],
                           .dst_rab[RAB$H_USZ],
                           .dst_dixtype,        ! destination system type
                           .rtrans,             ! transform structure
                           src_usage_typ,       ! src usage (may be altered)
                           dst_usage_typ);      ! dst usage (may be altered)
                 END;

            ! Set byte size to 36 if file is fortran binary.

            IF .src_typ[TYP$H_CLASS] EQL TYP$K_FORTRAN_BINARY
            THEN src_fab[FAB$V_BSZ] = 36;
            IF .dst_typ[TYP$H_CLASS] EQL TYP$K_FORTRAN_BINARY
            THEN dst_fab[FAB$V_BSZ] = 36;

            IF .request[DIU$H_KEY_SWITCH] NEQ 0 ! If there is key switch info
            THEN DO$KEY_ACTION(.request);      !  then process it

            ! If the source file is on TOPS-20, then set the byte size (based
            ! on the src_usage_typ), if it's not already set.  This is so that
            ! $OPEN of FFF files always works.  Next, set a value for the
            ! source TYP block class field if the file is local.  (For remote,
            ! this will cause errors!)  Next do the $OPEN.  For local files,
            ! call S$IFRMS which examines the file class bit in the FDB to
            ! determine whether the file is RMS or not.  If it's an RMS file,
            ! then turn off any TYP class value set previously.  This is
            ! necessary because: the $OPEN maps in the first page of the file
            ! and looks for a prologue.  If there is an RMS prologue then $OPEN
            ! knows it's an RMS file and ignores any value set in the TYP class
            ! field.  If there is no RMS prologue, then $OPEN will look at the
            ! TYP block class field and call F$OPEN (to open the foreign file).
            ! So, the $OPEN code is smart enough to ignore the TYP class value
            ! if the file is an RMS file.  However, the $CONNECT code doesn't
            ! have the option of looking at the prologue and therefore expects
            ! the TYP class field to tell the truth.  If $CONNECT thinks it has
            ! a non-RMS file, it tries to do an FFF $CONNECT which fails since
            ! F$OPEN was never really called.  NOTE: $CONNECT returns the
            ! useful error "Illegal arguemnt list" in this case.  SO, after the
            ! $OPEN we have to check the record format and determine if the
            ! file is or is not an RMS file.  If it is an RMS file, set the TYP
            ! class to nil, so that $CONNECT can win.  NOTE: This is only a
            ! problem for LOCAL files, since all VAX/VMS files are RMS anyway,
            ! and on remote 20 files you get a DAP protocol error if the TYP
            ! class bit is set.

            IF .src_ostype EQL XAB$K_TOPS20 AND .src_typ[TYP$H_CLASS] EQL 0
            THEN SELECTONE .src_usage_typ OF ! set TYP class
                 SET
                 [unspec_typ, default_typ, ascii_txt] :
                     BEGIN
                     src_fab[FAB$V_BSZ] = 7;    ! always set byte size
                     IF NOT .src_fab[FAB$V_REMOTE] 
                        AND .src_typ [TYP$H_CLASS] EQL 0
                     THEN src_typ [TYP$H_CLASS] = typ$k_ascii;       ! default
                     END;

                 [ebcdic_txt] :
                     BEGIN
                     src_fab[FAB$V_BSZ] = 9;    ! always set byte size
                     IF NOT .src_fab[FAB$V_REMOTE] 
                        AND .src_typ [TYP$H_CLASS] EQL 0
                     THEN src_typ [TYP$H_CLASS] = typ$k_ebcdic;
                     END;

                [sixbit_txt] :
                     BEGIN
                     src_fab[FAB$V_BSZ] = 6;    ! always set byte size
                     IF NOT .src_fab[FAB$V_REMOTE] 
                        AND .src_typ [TYP$H_CLASS] EQL 0
                     THEN src_typ [TYP$H_CLASS] = typ$k_sixbit;
                     END;
                 TES
            ELSE IF .src_typ [TYP$H_CLASS] EQL typ$k_image      ! class is img
                 THEN src_fab[FAB$V_BSZ] = 36;                  ! set bsz to 36

            ! open the source file

            $OPEN (FAB = src_fab);

            ! If a bypassable error occurred, exit block

            IF NOT $RMS_STATUS_OK(src_fab)      ! did the $OPEN go OK?
            THEN BEGIN
                 IF DO$BYPASS(src_fab)          ! if a bypassable error
                 THEN LEAVE process;            ! then exit block
                 SIGNAL(.src_fab[FAB$H_STS],    ! else signal error
                        .src_fab[FAB$H_STV],
                        src_fab);
                 END;

            ! Now that the source file is open, if it's local, and it's RMS
            ! file then clear the class field of the TYP block.
            
            IF NOT .src_fab[FAB$V_REMOTE]               ! local files only
            THEN BEGIN
                 IF S$IFRMS(.src_fab[FAB$H_JFN])        ! if it is an RMS file
                 THEN src_typ[TYP$H_CLASS] = 0
                 END;

            $TRACE('DO$COPY $OPEN of input file OK');

            ! If there are multiple output files and this is NOT the first file
            ! copied (we do the $PARSE earlier for the first copy operation)
            ! and this is a local file, then call $PARSE.  For local operations
            ! only, due to a problem in RMS, the $PARSE must be AFTER the $OPEN
            ! of the source file.  If this problem in RMS is fixed, this code
            ! should go away.

            IF (.many_out AND .copy_count NEQ 0               ! [201]
                AND NOT .dst_fab[FAB$V_REMOTE])               ! [201]
                ! never $parse the output filespec if appending since
                ! wildcards are not supported on append...
                AND (.request [DIU$H_FUNCTION] NEQ DIU$K_APPEND) ! [201]
            THEN $PARSE (FAB = dst_fab);                      ! [201]

            ! Copy the XAB information, and also set any explicit
            ! information they gave us via qualifiers
            DO$ATTRIBUTE_COPY(src_rab, dst_rab);
            DO$LOAD_BLOCKS(dst_rab, dest_buffer, dest, dest_len, dfnm);

            ! Check the transfer mode, copy the file, and confirm the act
            DO$SETUP_COPY(src_rab, dst_rab, doflags, count,
                          .request[DIU$H_FUNCTION]);
            DO$FILE_COPY(src_rab, dst_rab, count);
            DO$CONFIRM(src_fab, dst_fab, .request, .count);
            copy_count = .copy_count + 1;

            $CLOSE(FAB = src_fab, ERR = RMS$SIGNAL);
            $TRACE('DO$COPY $CLOSE of input file OK');

            ! If multiple output files, close the destination file
            ! or disconnect if we are appending.
            IF .many_out
            THEN BEGIN
                 $CLOSE(FAB = dst_fab, ERR = RMS$SIGNAL);
                 $TRACE('DO$COPY $CLOSE of Output file OK');
                 outfile_open = FALSE;
                 END
            ELSE $DISCONNECT(RAB = dst_rab);

          END;                          ! end PROCESS block

          $SEARCH(FAB = src_fab);       ! Lets go around again (whee!!)

        END;                            ! end next-file loop

     ! Find the next filespec, and look ahead one byte

     remaining = CH$DIFF(.eob, .src);
     src = CH$FIND_CH(.remaining, .src, $ETG);
     next_ptr = CH$PLUS(.src, 1);

   END     ! Find the next filespec, and look ahead one byte
UNTIL CH$RCHAR(.next_ptr) EQL $NUL;     ! until end of source filespecs 

IF NOT .many_out                        ! if concatenating
THEN BEGIN                              ! then close the file
     $CLOSE(FAB = dst_fab, ERR = RMS$SIGNAL);
     $TRACE('DO$COPY $CLOSE of output file OK');
     END;

! If there was more than one file copied, then print the n files copied or n
! files appended message.  If we did data conversion, then generate conversion
! statistics report.

IF .request[DIU$H_FUNCTION] EQL DIU$K_COPY      ! Was it a copy?
THEN function_code = PP('copied')               ! yes, label it as files copied
ELSE function_code = PP('appended');            ! no, label as appended

IF .copy_count GTR 1 THEN               ! More than one file?
$MSG_FAO(' Total of !SL files !AZ', .copy_count, .function_code);       ! Yes

IF .rtrans NEQ 0                        ! Did we do transformation?
THEN DIU$CSR(.rtrans);                  ! Yes, gen conv statistics report

RETURN DIU$_NORMAL;                     ! Return normal

END;                                    ! End of DO$COPY
%SBTTL 'DO$DELETE - Execute A DELETE Request'

GLOBAL ROUTINE DO$DELETE (request : REF $DIU_BLOCK) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Delete a file.
!
! FORMAL PARAMETERS:
!
!       request : Address of a DIU request block which is used
!                 to issue delete request.
!
! COMPLETION CODES:
!
!       NONE
!
! SIDE EFFECTS:
!
!       NONE
!
!--
LABEL process;

LOCAL status,
      eob,
      src,                
      src_len,
      dest,
      dest_len,
      remaining,
      next_ptr,
      count : INITIAL(0),
      current : $STR_DESCRIPTOR();

ENABLE DO$HANDLER(src_fab);

$TRACE(DO$DELETE);

! Set up pointer to the end of source_buffer.  Find the first file in
! the source buffer, if empty signal.

eob = CH$PLUS(CH$PTR(source_buffer), .source_length);
src = CH$FIND_CH(.source_length, CH$PTR(source_buffer), $ETG);
IF CH$FAIL(.src)
THEN SIGNAL(DIU$_INV_STR_LENGTH);

!
! Check all the filespecs until we have reached the end of the sources
!
DO BEGIN
   src_len = CH$A_RCHAR(src);           ! get the length of the filespec
   $STR_DESC_INIT(DESC = current,       ! build descriptor
                  CLASS = BOUNDED,
                  STRING = (.src_len, .src));

   DO$INIT_BLOCKS();                    ! Initialize the RMS blocks

   ! Load the RMS blocks from the qualifiers given AFTER offsetting length

   src = CH$PLUS(.src, 1);              ! increment ptr
   DO$LOAD_BLOCKS(src_rab, source_buffer,
                  src, src_len, sfnm);  ! load RMS blocks w/ tags from filespec

   $PARSE(FAB=src_fab,ERR=RMS$SIGNAL);
   $SEARCH(FAB=src_fab);                ! Set up wildcard context

   IF NOT (.src_nam[NAM$V_WILD_DIR] OR  ! wildcarded file spec?
           .src_nam[NAM$V_WILD_NAME] OR
           .src_nam[NAM$V_WILD_TYPE] OR
           .src_nam[NAM$V_WILD_VER])
   THEN src_fab [FAB$V_DRJ] = 0         ! no wildards, so release this JFN
   ELSE src_fab [FAB$V_DRJ] = 1;        ! have wildcards, don't release JFN


   UNTIL .src_fab[fab$H_STS] EQL RMS$_NMF DO    ! until there are no more files
       BEGIN

process: BEGIN

         IF NOT $RMS_STATUS_OK(src_fab)         ! did the $SEARCH go OK?
         THEN BEGIN
              IF DO$BYPASS(src_fab)             ! if a bypassable error
              THEN LEAVE process;               ! then exit block
              SIGNAL(.src_fab[FAB$H_STS],       ! else signal error
                     .src_fab[FAB$H_STV],
                     src_fab);
              END;

         !
         ! Using $ERASE, there is no way to deallocate the space used by
         ! a file across the net.  So, to delete a file, we have to open
         ! the file to get the XAB's filled in and get the size of the
         ! file.  Then, set the delete-on-close bit, and close the file.
         ! This ensures that the space is deallocated on the delete...
         ! (NOTE:  The NAM$V_SRCHFILL bit, currently not supported, is
         ! supposed to fix this behavior.  The NAM$V_SRCHFILL is supposed
         ! to mimic the behavior of the RMS-32 bit NAM$V_SRCHXABS.)
         !

         src_fab[FAB$V_DLT] = TRUE;     ! set the delete-on-close bit
         $OPEN(FAB = src_fab);          ! open the file

         IF NOT $RMS_STATUS_OK(src_fab)         ! did the $OPEN go OK?
         THEN BEGIN
              IF DO$BYPASS(src_fab)             ! if a bypassable error
              THEN LEAVE process;               ! then exit block
              SIGNAL(.src_fab[FAB$H_STS],       ! else signal error
                     .src_fab[FAB$H_STV],
                     src_fab);
              END;

         $CLOSE(FAB=src_fab, ERR=RMS$SIGNAL);   ! close the file

         IF NOT $RMS_STATUS_OK(src_fab)         ! did the $CLOSE go OK?
         THEN BEGIN
              IF DO$BYPASS(src_fab)             ! if a bypassable error
              THEN LEAVE process;               ! then exit block
              SIGNAL(.src_fab[FAB$H_STS],       ! else signal error
                     .src_fab[FAB$H_STV],
                     src_fab);
              END;

         count = .count + 1;
         DO$CONFIRM(src_fab, 0, .request, .src_fab[FAB$G_ALQ]);

         END;                           ! end PROCESS block

       $SEARCH(FAB=src_fab);            ! find next (wildcard) file

       END;

   ! Find the next filespec, and look ahead one byte
   remaining = CH$DIFF(.eob,.src);
   src       = CH$FIND_CH(.remaining,.src,$ETG);
   next_ptr  = CH$PLUS(.src,1);

END UNTIL CH$RCHAR(.next_ptr) EQL $NUL; ! Check all filespecs until we have
                                        !  reached the end of the sources

IF .count GTR 1                         ! Tell them how many files were deleted
THEN $MSG_FAO(' Total of !SL files deleted', .count);

src_fab[FAB$V_DRJ]=0;   ! Do release JFN & everything
$CLOSE(FAB=src_fab);   ! Try to close the source file

RETURN DIU$_NORMAL

END;                                    ! end of DO$DELETE
%SBTTL 'DO$SUBMIT - Execute a PRINT or SUBMIT Request'

GLOBAL ROUTINE DO$SUBMIT (request : REF $DIU_BLOCK) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Handle the print and submit commands for DIU-20. Both of these can be
!       handled in the same manner except for setting the SPL or SCF bits.
!       This is easily conditionalized below.
!
!       If the destination system is a TOPS-10/20 system, then set the record
!       format to stream to avoid getting an RMS batch or print file.
!
!       If they gave us a destination file, copy source to destination and then
!       print.  If they just gave us a source, set the bit, and just close.
!
! FORMAL PARAMETERS:
!
!       request : Address of a DIU request block which we will process
!    
!--
LABEL process;

ENABLE DO$HANDLER(src_fab,dst_fab,src_rab,dst_rab);

LOCAL file_count: INITIAL(0),
      status,
      eob,
      src,                
      src_len,
      remaining,
      next_ptr,
      dest,
      dest_len,
      count : INITIAL(0),
      current : $STR_DESCRIPTOR();

$TRACE(DO$SUBMIT);

! Find the first file in the source buffer, if empty send our regrets..

eob = CH$PLUS(CH$PTR(source_buffer),.source_length);
src = CH$FIND_CH(.source_length,CH$PTR(source_buffer),$ETG);
IF CH$FAIL(.src) THEN SIGNAL(DIU$_INV_STR_LENGTH);

DO$INIT_BLOCKS();                       ! Initialize the RMS blocks

DO BEGIN

   ! Get the length of the filespec and build descriptor

   src_len = CH$A_RCHAR(src);
   $STR_DESC_INIT(DESC=current,CLASS=BOUNDED,STRING=(.src_len,.src));

   ! Load the RMS blocks from the source file qualifiers

   src = CH$PLUS(.src,1);
   DO$LOAD_BLOCKS(src_rab,source_buffer,src,src_len,sfnm);
   src_fab[FAB$V_RFM] = FAB$K_STM;      ! We want steam!

   ! Set up wildcard context

   $PARSE(FAB=src_fab, ERR=RMS$SIGNAL);
   $TRACE('DO$SUBMIT Parse of input OK');
   $SEARCH(FAB=src_fab, ERR=RMS$SIGNAL);
   $TRACE('DO$SUBMIT Search of input OK');

   ! Loop for all input files

   UNTIL .src_fab[FAB$H_STS] EQL RMS$_NMF       ! Until no more files
   DO BEGIN                                     ! process each one

   process: BEGIN

            IF NOT $RMS_STATUS_OK(src_fab)      ! Status of FAB OK?
            THEN BEGIN                          ! No
                 IF DO$BYPASS(src_fab)          ! Is it a continuable error?
                 THEN LEAVE process;            ! Yes
                 SIGNAL(.src_fab[FAB$H_STS],    ! Some other form of error
                        .src_fab[FAB$H_STV], src_fab);
                 END;

            $OPEN(FAB=src_fab);                 ! Open the source file
            IF NOT $RMS_STATUS_OK(src_fab)      ! Status OK?
            THEN BEGIN                          ! No
                 IF DO$BYPASS(src_fab)          ! An error we punt on?
                 THEN LEAVE process;            ! No, just punt this file
                 SIGNAL(.src_fab[FAB$H_STS],    ! Bad error, punt the request
                        .src_fab[FAB$H_STV], src_fab);
                 END;

            $TRACE('DO$SUBMIT Opened input file OK');

            IF .request[DIU$H_DESTINATION_FILESPEC] GTR 0
            THEN BEGIN
                 $TRACE('DO$SUBMIT Output file specified, copying');
                   
                 dest = CH$FIND_CH(.dest_length,CH$PTR(dest_buffer),$ETG);
                 dest_len = CH$A_RCHAR(dest);
                 DEST = CH$PLUS(.dest,1);

                 ! Copy input file attributes over to output file

                 DO$ATTRIBUTE_COPY(src_rab,dst_rab);

                 ! Load the RMS blocks from the dest file qualifiers

                 DO$LOAD_BLOCKS(dst_rab,dest_buffer,dest,dest_len,dfnm);

                 IF NOT .outfile_open   ! If no output file yet
                 THEN BEGIN
                      $PARSE(FAB=dst_fab, ERR=RMS$SIGNAL);
                      $TRACE('DO$SUBMIT $PARSE of output file OK');

                      DO$OSTYPE_SETUP();        ! Set up my ostype

                      ! Set RFM stream. If not running to another LCG machine 
                      ! then set stream carriage return.

                      dst_fab[FAB$V_RFM] = FAB$K_STM;
                      IF .dst_ostype NEQ XAB$K_TOPS10
                         AND .dst_ostype NEQ XAB$K_TOPS20
                      THEN dst_fab[FAB$V_CR] = TRUE;
 
                      ! Determine if we are generating multiple output files

                      multiple = (.dst_nam[NAM$V_WILD_DIR]  OR
                                  .dst_nam[NAM$V_WILD_NAME] OR
                                  .dst_nam[NAM$V_WILD_TYPE] OR
                                  .dst_nam[NAM$V_WILD_VER]);
                      END;

                 ! In case they give us a comma listed group of input
                 ! files, be prepared to do append like operations.
                 ! Check the transfer mode, copy the file, and confirm act

                 DO$SETUP_COPY(src_rab,dst_rab,doflags,count,
                               .request[DIU$H_FUNCTION]);

                 DO$FILE_COPY(src_rab, dst_rab, count);

                 $TRACE('DO$SUBMIT File copied, setting spool or submit bit');

                 ! Set the right bit

                 IF .request[DIU$H_FUNCTION] EQL DIU$K_PRINT
                 THEN dst_fab[FAB$V_SPL] = TRUE
                 ELSE dst_fab[FAB$V_SCF] = TRUE;

                 appending = TRUE;
                 IF .multiple                   ! If multiple outputs then
                 THEN BEGIN                     !  close output file each time
                      $CLOSE(FAB=dst_fab,ERR=RMS$SIGNAL);
                      $TRACE('DO$SUBMIT Output file closed OK');
                      outfile_open = FALSE;     ! Output is no longer open
                      appending = FALSE;        ! Not appending if multi-output
                      END;

                 ! Add to total and confirm

                 file_count = .file_count + 1;
                 DO$CONFIRM(src_fab, dst_fab, .request, .count);

                 END

            ELSE BEGIN
                 $TRACE('DO$SUBMIT No output file given, printing source');

                 ! Set the right bit..

                 IF .request[DIU$H_FUNCTION] EQL DIU$K_PRINT
                 THEN src_fab[FAB$V_SPL] = TRUE
                 ELSE src_fab[FAB$V_SCF] = TRUE;

                 ! Tell the loser about the winnage

                 file_count = .file_count + 1;
                 DO$CONFIRM(src_fab, 0, .request, 0);
                 END;

            ! Close the source file

            $CLOSE(FAB = src_fab, ERR = RMS$SIGNAL);
            $TRACE('DO$SUBMIT Source file closed OK');

            END;                        ! end of PROCESS block

            $SEARCH(FAB = src_fab);     ! Go for the next one
            $TRACE ('DO$SUBMIT Search done');

     END;

     ! Find the next filespec, and look ahead one byte

     remaining = CH$DIFF(.eob, .src);
     src = CH$FIND_CH(.remaining, .src, $ETG);
     next_ptr = CH$PLUS(.src, 1);

! Check all the filespecs until we have reached the end of the sources

END UNTIL CH$RCHAR(.next_ptr) EQL $NUL;

! If we had comma listed input files, and a non-wildcarded output file
! (concatonated), close the output now.

IF .outfile_open THEN $CLOSE(FAB = dst_fab, ERR = RMS$SIGNAL);

! If printing/submitting more than one file give a message

IF .file_count GTR 1
THEN BEGIN
     IF .request[DIU$H_FUNCTION] EQL DIU$K_SUBMIT
     THEN $MSG_FAO(' Total of !SL files submitted', .file_count)
     ELSE $MSG_FAO(' Total of !SL files printed', .file_count);
     END;

RETURN DIU$_NORMAL;

END;                                    ! End of PRINT/SUBMIT
%SBTTL 'DO$RENAME - Execute a RENAME Request'

GLOBAL ROUTINE DO$RENAME (request : REF $DIU_BLOCK) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Process a RENAME request using RMS.
!
! FORMAL PARAMETERS:
!
!       request : Address of a DIU request block which we will process
!
!--

ENABLE DO$HANDLER(src_fab);

LOCAL src,                
      src_len,
      dest,
      dest_len,
      file_count: INITIAL(0),
      current : $STR_DESCRIPTOR();

OWN   oldfab : $FAB_DECL,
      newfab : $FAB_DECL,
      oldnam : $NAM_DECL,
      newnam : $NAM_DECL,
      newesabuf : VECTOR [CH$ALLOCATION(NAM$K_MAXRSS)],
      newrsabuf : VECTOR [CH$ALLOCATION(NAM$K_MAXRSS)],
      oldesabuf : VECTOR [CH$ALLOCATION(NAM$K_MAXRSS)],
      oldrsabuf : VECTOR [CH$ALLOCATION(NAM$K_MAXRSS)];

$TRACE(DO$RENAME);

! Carefully init FABs and NAMs, with two extra FABs to do the RENAME from.

DO$INIT_BLOCKS();                       ! Initialize the RMS blocks
src_nam[NAM$V_PWD] = 1;                 ! Need to keep password for source

$FAB_INIT(FAB = oldfab,                 ! FAB for "old" file spec
          FAC = GET, 
          NAM = oldnam,
          FNA = CH$PTR(srsa));

$FAB_INIT(FAB = newfab,                 ! FAB for "new" file spec
          FAC = PUT,
          NAM = newnam,
          FNA = CH$PTR(desa));

$NAM_INIT(NAM = oldnam,                 ! NAM for "old" name
          ESA = CH$PTR(oldesabuf), ESS = NAM$K_MAXRSS,
          RSA = CH$PTR(oldrsabuf), RSS = NAM$K_MAXRSS);

$NAM_INIT(NAM = newnam,                 ! NAM for "new" name
          ESA = CH$PTR(newesabuf), ESS = NAM$K_MAXRSS,
          RSA = CH$PTR(newrsabuf), RSS = NAM$K_MAXRSS);

! Find the source file, init RMS blocks to it

src  = CH$FIND_CH(.source_length, CH$PTR(source_buffer), $ETG);
IF CH$FAIL(src)                         ! Did we find one?
THEN SIGNAL(DIU$_INV_STR_LENGTH);       ! No
src_len = CH$A_RCHAR(src);              ! get length of filespec
src = CH$PLUS(.src, 1);                 ! point to ASCII filespec
DO$LOAD_BLOCKS(src_rab, source_buffer, src, src_len, sfnm);

! Find the destination file, init RMS blocks to it

dest = CH$FIND_CH(.dest_length,CH$PTR(dest_buffer),$ETG);
IF CH$FAIL(.dest)                       ! Did we find one?
THEN SIGNAL(DIU$_INV_STR_LENGTH);       ! No
dest_len = CH$A_RCHAR(dest);            ! Load length of filespec
dest = CH$PLUS(.dest, 1);               ! Load pointer to filespec
DO$LOAD_BLOCKS(dst_rab, dest_buffer, dest, dest_len, dfnm);

! Do the first $PARSE here to set up the source context and make sure that
! at least one input file exists.  Signal error if $PARSE doesn't work.

$PARSE(FAB = src_fab, ERR = RMS$SIGNAL);        ! Parse input filespec
$TRACE('DO$RENAME $PARSE of input file OK');
$SEARCH(FAB = src_fab, ERR = RMS$SIGNAL);       ! Set up wildcard context
$TRACE('DO$RENAME $SEARCH of input file OK');

! Loop around picking up and renaming each file matched by the specified input.

DO BEGIN                                ! Loop thru all files

   ! $SEARCH was done- check returned status

   IF NOT $RMS_STATUS_OK(src_fab)       ! Did the $SEARCH go OK?
   THEN SIGNAL(.src_fab[FAB$H_STS],     ! No, signal error
               .src_fab[FAB$H_STV],
               src_fab);
   $TRACE('DO$RENAME $SEARCH found input file');

   ! Fill in wildcard context for output file

   $PARSE(FAB = dst_fab);               ! Fill in output file
   IF NOT $RMS_STATUS_OK(dst_fab)       ! Did the $PARSE go OK?
   THEN SIGNAL(.dst_fab[FAB$H_STS],     ! No, signal error
               .dst_fab[FAB$H_STV],
               dst_fab);
   $TRACE('DO$RENAME $PARSE done for output file');

   ! We have the filenames, make them ASCIZ, close unneeded FABs

   $CLOSE(FAB = src_fab);               ! Close source
   $CLOSE(FAB = dst_fab);               ! Close destination
   CH$WCHAR(0,CH$PLUS(CH$PTR(srsa),.src_nam[NAM$H_RSL]));       ! ASCIZ src
   CH$WCHAR(0,CH$PLUS(CH$PTR(desa),.dst_nam[NAM$H_ESL]));       ! ASCIZ dst
   newnam[NAM$H_RSL] = 0;               ! Don't want RMS using that NAM
   newnam[NAM$H_ESL] = 0;               !  block information from last file
   
   ! Go ahead and do the rename, check the error

   $RENAME(OLDFAB = oldfab, NEWFAB = newfab);
   IF NOT $RMS_STATUS_OK(oldfab)        ! Did the $RENAME go OK?
   THEN SIGNAL(.oldfab[FAB$H_STS],      ! No, signal error
               .oldfab[FAB$H_STV],
               oldfab);
   $TRACE('DO$RENAME $RENAME went OK');
   file_count = .file_count + 1;        ! Increment file count

   ! Display success.  [230] Work around RMS bug where a local rename doesn't
   ! return the RSA in the old FAB's NAM block

   IF .src_fab[FAB$V_REMOTE]            ! Remote rename?
   THEN DO$CONFIRM(oldfab, newfab, .request, 0)         ! Yes display remote
   ELSE DO$CONFIRM(src_fab, newfab, .request, 0);       ! No, display local

   ! Get another input file, if any, and loop

   $PARSE(FAB = src_fab);               ! Parse to get another source jfn
   IF NOT $RMS_STATUS_OK(src_fab)               ! Is there an error?
   THEN BEGIN                                   ! Yes
        IF .src_fab[FAB$H_STS] EQL RMS$_FNF     ! All done with these files?
        THEN EXITLOOP;                          ! Yes, exit loop please
        SIGNAL(.src_fab[FAB$H_STS],             ! No, signal error
               .src_fab[FAB$H_STV],
               src_fab);
        END;
   $TRACE('DO$RENAME did another $PARSE');

   ! Search for the next input file (if any) and loop.  TOPS-10 doesn't
   ! give an error until here.

   $SEARCH(FAB = src_fab);                      ! Search (yet) again
   IF NOT $RMS_STATUS_OK(src_fab)               ! Is there an error?
   THEN BEGIN                                   ! Yes
        IF .src_fab[FAB$H_STS] EQL RMS$_FNF     ! All done with these files?
        THEN EXITLOOP;                          ! Yes, exit loop please
        SIGNAL(.src_fab[FAB$H_STS],             ! No, signal error
               .src_fab[FAB$H_STV],
               src_fab);
        END;
   $TRACE('DO$RENAME did another $SEARCH');

   END WHILE 1;                         ! end file process loop

! If more than one file renamed, then give message with total number.

IF .file_count GTR 1 THEN $MSG_FAO(' Total of !SL files renamed',.file_count);

RETURN DIU$_NORMAL;

END;                                    ! End of DO$RENAME
%SBTTL 'DO$INIT_BLOCKS - Initialize RMS blocks'

ROUTINE DO$INIT_BLOCKS : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!       Initialize the RMS blocks used to process the request.
!
! IMPLICIT OUTPUTS
!
!       The following RMS blocks are initalized: src_fab, dst_fab, src_rab,
!       dst_rab, src_nam, dst_nam, src_typ, dst_typ, srcsum_xabsum,
!       dstsum_xabsum, srccfg_xabcfg, dstcfg_xabcfg, srcdat_xabdat,
!       dstdat_xabdat.
!
!--

$TRACE(DO$INIT_BLOCKS);

! Initialize the source RAB

$RAB_INIT(RAB=src_rab,                          ! Dest file RAB
          FAB=src_fab,                          ! Dest file FAB
          RAC=TRA,                              ! Block file transfer mode
          UBF=sbuf,                             ! Input file buffer 
          USZ=DAP$K_BUFFER_SIZE_IN_WORDS);      ! DAP buffer size

! Initialize the destination RAB

$RAB_INIT(RAB=dst_rab,                          ! Dest file RAB
          FAB=dst_fab,                          ! Dest file FAB
          RAC=TRA,                              ! Block file transfer mode
          UBF=dbuf,                             ! Output file buffer
          USZ=DAP$K_BUFFER_SIZE_IN_WORDS);      ! DAP buffer size

! Initialize the source FAB

$FAB_INIT(FAB=src_fab,     FOP=<NAM>,         FAC=<GET,BRO>,    TYP=src_typ,
          SHR=GET,         NAM=src_nam,       XAB=srcsum_xabsum);

! Initialize the destination FAB

$FAB_INIT(FAB=dst_fab,       FOP=<OFP,NAM,SUP>,
          FAC=PUT,           TYP=dst_typ,
          SHR=NIL,           NAM=dst_nam,    XAB=dstsum_xabsum,
          RFM=VAR,           ORG=SEQ,        RAT=NIL);

! Initialize the source NAM

$NAM_INIT(NAM=src_nam,        RSA=CH$PTR(srsa), RSS=NAM$K_MAXRSS,
                              ESA=CH$PTR(sesa), ESS=NAM$K_MAXRSS);

! Initialize the destination NAM

$NAM_INIT(NAM=dst_nam,        RSA=CH$PTR(drsa), RSS=NAM$K_MAXRSS,
                              ESA=CH$PTR(desa), ESS=NAM$K_MAXRSS,
                              RLF=src_nam);

!dst_nam [NAM$V_SYNCHK] = TRUE;
! Remove the setting of the SYNCHK bit.  If it's on, the config XAB is
! not filled in and therefore we can't get the operating system type...
!( Set for syntax_check_only to avoid setting up a wildcard context.  We
!  never $SEARCH this $NAM block anyway, and we may lose freecore if
!  the $NAM is re-initialized improperly. )

! Initialize the source file XABs and build chain

$XABSUM_INIT(XAB=srcsum_xabsum,  NXT=srccfg_xabcfg);
$XABCFG_INIT(XAB=srccfg_xabcfg,  NXT=srcdat_xabdat);
$XABDAT_INIT(XAB=srcdat_xabdat);

! Initialize the destination file XABs and build chain

$XABSUM_INIT(XAB=dstsum_xabsum, NXT=dstcfg_xabcfg);
$XABCFG_INIT(XAB=dstcfg_xabcfg, NXT=dstdat_xabdat);
$XABDAT_INIT(XAB=dstdat_xabdat);

! Initialize the source and destination TYP blocks

$TYP_INIT(TYP=src_typ);
$TYP_INIT(TYP=dst_typ);

src_usage_typ = default_typ;            ! initialize src and dst usage types
dst_usage_typ = default_typ;

END;                                    ! end DO$INIT_BLOCKS
%SBTTL 'DO$OSTYPE_SETUP - Setup OS Types'

ROUTINE DO$OSTYPE_SETUP : NOVALUE =
BEGIN
!++
!
!  FUNCTIONAL DESCRIPTION:
!
!       This routine  is  called  to  figure out  the  source  and  destination
!       operating system types for later  reference in DO$SETUP_COPY and  other
!       places.
!
!  IMPLICIT INPUTS:
!
!       src_fab[FAB$V_REMOTE]
!       srccfg_xabcfg[XAB$B_OSTYPE]
!       dst_fab[FAB$V_REMOTE]
!       dstcfg_xabcfg[XAB$B_OSTYPE]
!
!  IMPLICT OUTPUTS:
!
!       src_ostype
!       src_dixtype
!       dst_ostype
!       dst_dixtype
!
!--

! Figure out who is the "from" side is and set up the operating system types

IF .src_fab[FAB$V_REMOTE]
THEN src_ostype = .srccfg_xabcfg[XAB$B_OSTYPE]
ELSE src_ostype = our_ostype;

src_dixtype = (SELECT .src_ostype OF
               SET
               [XAB$K_TOPS20, XAB$K_TOPS10] : sys_lcg;
               [XAB$K_VMS] : sys_8bit;
               [OTHERWISE] : sys_pro;
               TES);

! Figure out who the "to" side is and set the operating system types up

IF .dst_fab[FAB$V_REMOTE]
THEN dst_ostype = .dstcfg_xabcfg[XAB$B_OSTYPE]
ELSE dst_ostype = our_ostype;

dst_dixtype = (SELECT .dst_ostype OF
               SET
               [XAB$K_TOPS20, XAB$K_TOPS10] : sys_lcg;
               [XAB$K_VMS] : sys_8bit;
               [OTHERWISE] : sys_pro;
               TES);


END;                                    ! DO$OSTYPE_SETUP
%SBTTL 'DO$SETUP_COPY - Setup Transfer Context'

ROUTINE DO$SETUP_COPY (src_rab : REF $RAB_DECL,
                       dst_rab : REF $RAB_DECL,
                       p_flag,
                       p_count,
                       diu_function) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Determine if page mode (same as block mode) (/IMAGE) was specified or
!       must be used (for TOPS-10).  Connect the RABs and set the multiple
!       output flag if there is a wildcarded output file.
!
! FORMAL PARAMETERS:
!
!       src_rab : Addr of RMS RAB of source file
!       dst_rab : Addr of RMS RAB of destination file
!       p_flag : BITVECTOR as follows
!            bit 0 : indicates whether or not the output file is open.  This
!                    bit should be set on entry if the output file is open,
!                    otherwise this routine will create the file and set this.
!            bit 1 : <NOT USED>
!            bit 2 : Appending/concatenating files
!            bit 3 : Multiple output files
!       p_count : record count
!       diu_function : literal value indicating function (COPY, APPEND, etc.)
!
! SIDE EFFECTS:
!
!       RMS data structures modified.
!
!--
BIND count = .p_count,
     doflags = .p_flag: BITVECTOR,
     src_fab = .src_rab[RAB$A_FAB] : $FAB_DECL,
     src_typ = .src_fab[FAB$A_TYP] : $TYP_DECL,
     src_nam = .src_fab[FAB$A_NAM] : $NAM_DECL,
     src_sum = .src_fab[FAB$A_XAB] : $XABSUM_DECL,
     src_cfg = .src_sum[XAB$A_NXT] : $XABCFG_DECL,
     dst_fab = .dst_rab[RAB$A_FAB] : $FAB_DECL,
     dst_typ = .dst_fab[FAB$A_TYP] : $TYP_DECL,
     dst_nam = .dst_fab[FAB$A_NAM] : $NAM_DECL,
     dst_sum = .dst_fab[FAB$A_XAB] : $XABSUM_DECL,
     dst_cfg = .dst_sum[XAB$A_NXT] : $XABCFG_DECL;

$TRACE(DO$SETUP_COPY);

! The following is a system-dependent check for directory.  This is necessary
! because DAP does not provide any way to pass the "this is a directory" bit
! over the network.  We can't just try to read it because VMS breaks the link
! if you do a $GET on a directory file, and no operating system wants us to
! $PUT to them.  The following code will check each file name and determine
! whether it is a directory (based on the system type).  If it is a directory
! then signal that the file is protected.

IF (SELECTONE .src_ostype OF
    SET
    [XAB$K_VMS]:                        ! VMS
        BEGIN
        (.src_fab[FAB$V_CR] EQL 0)
        AND (.src_fab[FAB$V_RFM] EQL FAB$K_VAR)
        AND $STR_EQL (STRING1 = (.src_nam[NAM$B_TYPE], .src_nam[NAM$A_TYPE]),
                      STRING2 = 'DIR')
        END;
    [XAB$K_TOPS20]:                     ! TOPS-20
        $STR_EQL (STRING1 = (.src_nam[NAM$B_TYPE], .src_nam[NAM$A_TYPE]),
                  STRING2 = 'DIRECTORY');
    [XAB$K_TOPS10]:                     ! TOPS-10: Should we check for UFDs too
        $STR_EQL (STRING1 = (.src_nam[NAM$B_TYPE], .src_nam[NAM$A_TYPE]),
                  STRING2 = 'SFD');
    [OTHERWISE]: 0;                     ! All others (mostly PDP-11 Op Sys)
    TES)
THEN BEGIN
     $CLOSE (FAB = src_fab);                    ! Close it if it's open
     SIGNAL(src_fab[FAB$H_STS] = RMS$_PRV)      ! Say it's protected
     END;

! Determine if we are doing a block mode or a record mode transfer.  If we can,
! then set the block_mode_flag.  If the user specified /IMAGE but is copying
! to/from a non-TOPS-10/20 system, then signal error.

block_mode_flag = 0;                            ! Assume not block mode
IF .src_fab[FAB$V_BIO]                          ! /IMAGE was specified?
THEN IF (.src_ostype EQL XAB$K_TOPS20           ! if src oper sys is TOPS-20
          OR .src_ostype EQL XAB$K_TOPS10)      ! or src oper sys is TOPS-10
       AND (.dst_ostype EQL XAB$K_TOPS20        ! and dst oper sys is TOPS-20
             OR .dst_ostype EQL XAB$K_TOPS10)   ! or dst oper sys is TOPS-10
     THEN block_mode_flag = 1                   ! set block mode flag
     ELSE SIGNAL (DIU$_IMAGE_INVALID);          ! else signal error

! set up for either block mode or record mode transfer

IF .block_mode_flag                             ! Block mode transfer?
THEN BEGIN                                      ! Yes

     ! Set up for block mode copy

     $TRACE('DO$SETUP_COPY Block mode transfer setup');

     ! always set type class to image

     src_typ[TYP$H_CLASS] = dst_typ[TYP$H_CLASS] = TYP$K_IMAGE;

     src_fab[FAB$V_BRO] = dst_fab[FAB$V_BRO] = TRUE;
     src_fab[FAB$V_BIO] = dst_fab[FAB$V_BIO] = FALSE;

     ! Assume 20-20 file transfers (BFT mode).  Handle differently (what ever
     ! works) for TOPS-10.  If the FAL-10 would send 512 word packets like we
     ! want (if the FAL-10 supported TRA or BFT properly too) much of this
     ! rudeness could be removed.

     src_rab[RAB$B_RAC] = dst_rab[RAB$B_RAC] = RAB$K_BFT;

     IF .src_ostype EQL XAB$K_TOPS10            ! Is src o/s is TOPS-10?
     THEN BEGIN                                 ! Yes
          src_rab[RAB$B_RAC] = RAB$K_TRA;       ! TRA for read
          dst_rab[RAB$B_RAC] = RAB$K_SEQ;       ! SEQ for write
          END;
     IF .dst_ostype EQL XAB$K_TOPS10            ! Is the dst o/s is TOPS-10?
     THEN dst_rab[RAB$B_RAC] = RAB$K_TRA;       ! TRA for the old FAL-10

     src_fab[FAB$V_BSZ] = dst_fab[FAB$V_BSZ] = 36;
     src_fab[FAB$V_RFM] = dst_fab[FAB$V_RFM] = FAB$K_UDF;
     src_fab[FAB$H_MRS] = dst_fab[FAB$H_MRS] = 512;

     END

ELSE BEGIN                              ! Begin non-block mode code

     $TRACE('DO$SETUP_COPY Record mode transfer setup');

     src_fab[FAB$V_BIO] = dst_fab[FAB$V_BIO] = FALSE;   ! Turn off block mode 

     IF (.dst_ostype EQL XAB$K_TOPS10           ! these systems don't
         OR .dst_ostype EQL XAB$K_TOPS20)       !  support record formats
        AND (.dst_fab[FAB$V_RFM] EQL FAB$K_SCR  !  SCR, SLF and VFC
             OR .dst_fab[FAB$V_RFM] EQL FAB$K_SLF
             OR .dst_fab[FAB$V_RFM] EQL FAB$K_VFC)
     THEN SIGNAL (DIU$_INVALID_RFM);            ! so signal error

     IF .rtrans NEQ 0                   ! If a transform was specified
     THEN BEGIN

          ! If a transform was specified, then the destination records size
          ! (RSZ) will need to be adjusted to reflect the byte size (BSZ) of
          ! the new record.  For VMS and PRO systems, set the dst type class
          ! to DIL8 to force RMS to copy the data correctly to the VAX...

          IF (.dst_ostype EQL XAB$K_TOPS10 OR .dst_ostype EQL XAB$K_TOPS20)
          THEN ! 36 bit systems -- slack bits within record are included
               BEGIN
               LOCAL remainder,
                     bytes_per_word,
                     fullwords_per_record;

               SELECTONE .dst_usage_typ OF      ! set dst byte size
               SET
               [unspec_typ, default_typ, ascii_txt] :
                      dst_fab [FAB$V_BSZ] = 7;
               [ebcdic_txt] :
                      dst_fab [FAB$V_BSZ] = 9;
               [sixbit_txt] :
                      dst_fab [FAB$V_BSZ] = 6;
               TES;

               ! figure new destination record size

               fullwords_per_record = .bits_per_record / %BPVAL ;
               remainder = .bits_per_record MOD %BPVAL ;
               bytes_per_word = %BPVAL / .dst_fab[FAB$V_BSZ] ;

               dst_rab[RAB$H_RSZ]       ! set dst record size
                  =  ( .fullwords_per_record * .bytes_per_word )
                   + ( .remainder / .dst_fab[FAB$V_BSZ] ) ;  
               END
          ELSE
               BEGIN

               ! Always use 8-bit bytes for VAX/PRO systems

               dst_fab [FAB$V_BSZ] = 8;

               ! Force RMS to use DIL8 mode because the DIL routines will
               ! set up the data in 8-bit image mode for PRO or VAX systems.

               dst_typ[TYP$H_CLASS] = typ$k_DIL8;

               ! for 8-bit systems, divide by 8

               dst_rab[RAB$H_RSZ] = .bits_per_record/8; ! set dst record size
               END;

          ! If a transform was specified, then the record size may change (see
          ! above!) and so based on record format, adjust the MRS (and possibly
          ! the RSZ) as needed...

          SELECT .dst_fab[FAB$V_RFM] OF
          SET
          [FAB$K_FIX] :                 ! if implied CRLF adjust MRS and RSZ
                   IF .dst_fab[FAB$H_MRS] EQL 0
                   THEN BEGIN
                        dst_fab[FAB$H_MRS] = .dst_rab[RAB$H_RSZ] + 2;
                        dst_rab[RAB$H_RSZ] = .dst_rab[RAB$H_RSZ] + 2;
                        END
                   ELSE IF (.dst_fab[FAB$H_MRS] LSS .dst_rab[RAB$H_RSZ] + 2)
                        THEN SIGNAL(DIU$_RSZ_INVALID, 2,
                                    (.dst_rab[RAB$H_RSZ]+2),
                                     .dst_fab[FAB$H_MRS], 0);

          [FAB$K_STM] :                 ! add 2 TO MRS for CRLF
                   IF .dst_fab[FAB$H_MRS] EQL 0
                   THEN dst_fab[FAB$H_MRS] = .dst_rab[RAB$H_RSZ] + 2
                   ELSE IF (.dst_fab[FAB$H_MRS] LSS .dst_rab[RAB$H_RSZ] + 2)
                        THEN SIGNAL(DIU$_RSZ_INVALID, 2,
                                    (.dst_rab[RAB$H_RSZ]+2),
                                     .dst_fab[FAB$H_MRS], 0);

          [FAB$K_SCR, FAB$K_SLF] :      ! add 1 TO MRS for SCR or SLF
                   IF .dst_fab[FAB$H_MRS] EQL 0
                   THEN dst_fab[FAB$H_MRS] = .dst_rab[RAB$H_RSZ] + 1
                   ELSE IF (.dst_fab[FAB$H_MRS] LSS .dst_rab[RAB$H_RSZ] + 1)
                        THEN SIGNAL(DIU$_RSZ_INVALID, 2,
                                    (.dst_rab[RAB$H_RSZ]+1),
                                     .dst_fab[FAB$H_MRS], 0);

          [OTHERWISE] :
                   IF .dst_fab[FAB$H_MRS] EQL 0
                   THEN dst_fab[FAB$H_MRS] = .dst_rab [RAB$H_RSZ] + 2
                   ELSE IF (.dst_fab[FAB$H_MRS] LSS .dst_rab [RAB$H_RSZ])
                        THEN SIGNAL(DIU$_RSZ_INVALID, 2,
                                    (.dst_rab[RAB$H_RSZ]+2),
                                     .dst_fab[FAB$H_MRS], 0);
          TES;

          END;                          ! end if-transform-specified block

     ! The record access mode of record transfer mode (RAC=TRA), which is the
     ! default record access mode, does not work with relative organization.
     ! For relative, set RAC to SEQ (sequential access mode).

     IF .src_fab[FAB$V_ORG] EQL FAB$K_REL
     THEN src_rab[RAB$B_RAC] = RAB$K_SEQ;

     ! Set the connect append bit if we are appending

     IF .appending
     THEN dst_rab[RAB$V_EOF] = TRUE;

     END;                               ! end of record mode transfer setup
 
IF NOT .outfile_open                    ! if output file not open yet,
THEN BEGIN                              ! then create it

     LOCAL hold_fop : INITIAL (0);

     IF .dst_fab [FAB$V_ORG] EQL FAB$K_IDX      ! if the file is RMS index
     THEN IF .dst_ostype EQL XAB$K_TOPS20       ! if the file is on TOPS-20
          THEN dst_rab [RAB$B_RAC] = RAB$K_KEY  ! change access mode to key
          ELSE dst_rab [RAB$B_RAC] = RAB$K_TRA  ! else change it to TRA
     ELSE IF .dst_fab [FAB$V_ORG] EQL FAB$K_REL ! if RMS relative
          THEN BEGIN
               dst_rab [RAB$B_RAC] = RAB$K_KEY; ! access mode is key
               dst_rab [RAB$A_KBF] = count;     ! set up key buffer
               END;

     hold_fop = .dst_fab[FAB$H_FOP];

     ! If the function was an APPEND, then call $OPEN to open the file.
     ! Otherwise, if the function requested is a COPY, then call $CREATE
     ! to create the file.

     SELECTONE .diu_function OF
     SET [DIU$K_APPEND] :
             BEGIN

             $OPEN (FAB = dst_fab, ERR = RMS$SIGNAL);   ! Open the file

             ! Need to set up dst type class if APPEND specified on TOPS-20
             ! non-RMS file.

             IF .dst_ostype EQL our_ostype
               AND (.dst_fab[FAB$V_RFM] EQL FAB$K_UDF
                    OR .dst_fab[FAB$V_RFM] EQL FAB$K_STM
                    OR .dst_fab[FAB$V_RFM] EQL FAB$K_LSA)
             THEN SELECTONE .dst_usage_typ OF       ! set type class
                  SET
                  [unspec_typ, default_typ, ascii_txt] :
                      BEGIN
                      IF .dst_typ [TYP$H_CLASS] EQL 0
                      THEN dst_typ [TYP$H_CLASS] = typ$k_ascii;   ! default
                      dst_fab [FAB$V_BSZ] = 7;
                      END;
                   [ebcdic_txt] :
                      BEGIN
                      IF .dst_typ [TYP$H_CLASS] EQL 0
                      THEN dst_typ [TYP$H_CLASS] = typ$k_ebcdic;
                      dst_fab [FAB$V_BSZ] = 9;
                      END;
                  [sixbit_txt] :
                      BEGIN
                      IF .dst_typ [TYP$H_CLASS] EQL 0
                      THEN dst_typ [TYP$H_CLASS] = typ$k_sixbit;
                      dst_fab [FAB$V_BSZ] = 6;
                      END;
                  TES;
             END;

         [OTHERWISE] :
             $CREATE (FAB = dst_fab, ERR = RMS$SIGNAL); ! create the file
                      
     TES;

     ! If FAB$V_OFP is OFF when appending to a VAX then the $CREATE sets the
     ! FAB$H_FOP field to FAB$V_WAT (wait if file locked bit) only.  This is
     ! totally WRONG.  Therefore, until this RMS bug is fixed, always reset
     ! the FOP fields back to what they were before.

     dst_fab[FAB$H_FOP] = .hold_fop;

     outfile_open = true;                       ! indicate output file open
     END;

IF .block_mode_flag
THEN BEGIN
     src_fab[FAB$V_BIO] = dst_fab[FAB$V_BIO] = TRUE;
     src_fab[FAB$V_BRO] = dst_fab[FAB$V_BRO] = FALSE;
     END;

$CONNECT(RAB = .src_rab, ERR = RMS$SIGNAL);     ! connect source RAB
$CONNECT(RAB = .dst_rab, ERR = RMS$SIGNAL);     ! connect dest RAB

END;                                    ! End of DO$SETUP_COPY
%SBTTL 'DO$FILE_COPY - Execute COPY Loop'

ROUTINE DO$FILE_COPY (src_rab : REF $RAB_DECL,
                      dst_rab : REF $RAB_DECL,
                      p_count) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Copy a file until end of file or error
!
! FORMAL PARAMETERS:
!
!       src_rab : Addr of RMS RAB of source file
!       dst_rab : Addr of RMS RAB of destination file
!       p_count : record or block count
!
! SIDE EFFECTS:
!
!       File(s) will have been copied, RMS$_EOF will have been signalled.
!
!--
BIND count = .p_count,
     src_fab = .src_rab[RAB$A_FAB] : $FAB_DECL,
     dst_fab = .dst_rab[RAB$A_FAB] : $FAB_DECL;

LOCAL hell_freezes_over : INITIAL(0),
      wcount : INITIAL(0),
      crlf_flag : INITIAL(0);

ROUTINE COPY_HANDLER(signal_args : REF VECTOR,       ! Condition handler
                     mech_args   : REF VECTOR,       !  for COPY_UNTIL_EOF
                     enable_args : REF VECTOR)=      !  which causes it
    BEGIN                                            !  to return win ON EOF

    $TRACE(COPY_HANDLER);

    IF .signal_args[1] EQL RMS$_EOF     ! Is it EOF?
    THEN BEGIN                          ! Yes, this is what this is here for
         mech_args[1] = SS$_NORMAL;     ! Load a success status
         RETURN SETUNWIND();            ! Success return
         END;
   
    SS$_RESIGNAL                        ! Let other errors fall out

    END;                                ! End routine COPY_HANDLER

ENABLE COPY_HANDLER;

$TRACE(DO$FILE_COPY);

IF .block_mode_flag                     ! process in block (or page) mode
THEN BEGIN                              ! Yes, 36-36 bit transfer

     $TRACE('DO$FILE_COPY Beginning block mode transfer');

     ! On a 20 to 20 transfer, rfm 0 is the FDB.  Only copy an FDB to an FDB,
     ! and make sure it doesn't get counted in pages transferred.

     IF .src_ostype EQL XAB$K_TOPS20            ! if going from TOPS-20
        AND .dst_ostype EQL XAB$K_TOPS20        !  to TOPS-20 
     THEN BEGIN                                 ! 20-to-20: transfer FDB first
          src_rab[RAB$G_BKT] = 0;               ! Set src bkt to zero
          count = -1;                           ! Set pages transferred count 
          END
     ELSE BEGIN                                 ! Not 20-to-20: no FDB to xfer
          src_rab[RAB$G_BKT] = 1;               ! set src bkt to 1
          count = 0;                            ! Clear pages transfer count
          END;

     ! Loop until an error or EOF copying all pages/blocks of the file.

     DO BEGIN

        ! Read a block or page

        CH$FILL(0,512,CH$PTR(sbuf,0,36));       ! Zero the buffer
        $READ(RAB=.src_rab,ERR=RMS$SIGNAL);     ! Get a block

        ! Set the output page to the input page

        dst_rab[RAB$A_RBF] = .src_rab[RAB$A_RBF];
        dst_rab[RAB$A_UBF] = .src_rab[RAB$A_RBF];

        IF .dst_rab[RAB$B_RAC] EQL RAB$K_SEQ    ! Sequential writes?
        THEN BEGIN                              ! Yes, hack for -10 FAL

             dst_rab[RAB$H_RSZ] = .src_rab[RAB$H_RSZ];  ! Load words to move
             $PUT(RAB=.dst_rab,ERR=RMS$SIGNAL);         ! Write out n words
             wcount = .wcount + .src_rab[RAB$H_RSZ];    ! Count words written
             count = (.wcount+511)/512;                 ! Yuk compute pages

             END                        ! End of sequential writes block

        ELSE BEGIN                      ! TRA or BFT writes (pages)

             dst_rab[RAB$G_BKT] = .src_rab[RAB$G_RFA];  ! Set bkt number
             dst_rab[RAB$H_RSZ] = 512;                  ! Old FAL-20 feature

             $WRITE(RAB=.dst_rab,ERR=RMS$SIGNAL);       ! Write out a page

             IF .dst_ostype EQL XAB$K_TOPS10    ! If going to a blue machine
             THEN count = .count + 4            !  there are 4 blocks/page
             ELSE count = .count + 1;           !  otherwise bump up by a page

             src_rab[RAB$G_BKT] = .src_rab[RAB$G_RFA] + 1;      ! Incr unit cnt

             END;                       ! End of non-sequential write mode

        S$BREATHE();                    ! Let the spooler take a breath

        END UNTIL .hell_freezes_over;           ! Condition handler catches EOF

     END                                        ! end of block mode processing

ELSE BEGIN                                      ! else process in record mode

     BIND src_fab = .src_rab[RAB$A_FAB] : $FAB_DECL,
          src_typ = .src_fab[FAB$A_TYP] : $TYP_DECL,
          dst_fab = .dst_rab[RAB$A_FAB] : $FAB_DECL,
          dst_sum = .dst_fab[FAB$A_XAB] : $XABSUM_DECL,
          dst_cfg = .dst_sum[XAB$A_NXT] : $XABCFG_DECL;
     $TRACE('DO$FILE_COPY Beginning record mode transfer');

     count = 0;                                 ! Reset count of records

    DO BEGIN

       ! Clear the source buffer

       INCR cntr FROM 0 TO DAP$K_BUFFER_SIZE_IN_WORDS-1 
            DO sbuf[.cntr] = 0;

       ! Get a record

       $GET(RAB = .src_rab, ERR = RMS$SIGNAL);

       ! For destination TOPS-20 line sequence ASCII files, assign line numbers
       ! (since RMS-20 does not do this for you).  If the source file is also a
       ! line sequenced ASCII file then use the line sequence number from the
       ! source RAB; otherwise assign line sequence number in increments of
       ! 100.  If the line sequence number is too large (greater than 99999),
       ! then write a dummy record with the line sequence number set to -1, to
       ! force a page break (RMS writes a form-feed), and reset the line
       ! sequence number to 100.

       IF (.dst_ostype EQL XAB$K_TOPS20
           AND .dst_fab[FAB$V_RFM] EQL FAB$K_LSA)
       THEN IF .src_fab[FAB$V_RFM] EQL FAB$K_LSA        ! src file is LSA also
            THEN dst_rab[RAB$H_LSN] = .src_rab[RAB$H_LSN]       ! use src LSN
            ELSE BEGIN
                 dst_rab[RAB$H_LSN] = .dst_rab[RAB$H_LSN]+100;  ! make LSN
                 IF .dst_rab[RAB$H_LSN] GTR 99999       ! max line sequence num
                 THEN BEGIN
                      dst_rab[RAB$H_LSN] = -1;  ! set for new page
                      $PUT (RAB = .dst_rab, ERR = RMS$SIGNAL);  ! put new page
                      dst_rab[RAB$H_LSN] = 100; ! reset line seq num
                      END
                 END;

       ! Point buffer pointers at the proper spots

       IF .rtrans NEQ 0                 ! If doing data conversion
       THEN BEGIN                       ! Perform any data conversion required.
            dst_rab[RAB$A_RBF]=.dst_rab[RAB$A_UBF];

            DIU$EXECUTE_TRANS (.rtrans,
                               .src_rab[RAB$A_UBF],
                               .dst_rab[RAB$A_UBF],
                               .count+1);
            END
       ELSE BEGIN
            LOCAL src_ptr, dst_ptr;
            dst_rab[RAB$A_RBF] = .dst_rab[RAB$A_UBF];

            ! For TOPS-20 source files which are read in IMAGE mode and have
            ! byte size 36, figure the destination record size based on the
            ! byte size of the destination and number of words in the source.
            ! Also, figure the character pointers of BOTH buffers based on the
            ! destination byte size.  This all works OK since there is no data
            ! conversion happening.

            IF (.src_typ[TYP$H_CLASS] EQL typ$k_image)
               AND (.src_fab[FAB$V_BSZ] EQL 36)
               AND (.dst_fab[FAB$V_BSZ] NEQ 36)
            THEN BEGIN                  ! if source file is /IMAGE
                 dst_rab[RAB$H_RSZ] =
                     .src_rab[RAB$H_RSZ]*(36/.dst_fab[FAB$V_BSZ]);
                 src_ptr = CH$PTR(.src_rab[RAB$A_UBF], 0,
                                  .dst_fab[FAB$V_BSZ]); ! yes, this should be dst fab
                 dst_ptr = CH$PTR(.dst_rab[RAB$A_UBF], 0,
                                  .dst_fab[FAB$V_BSZ]);

                 ! copy source user buffer to destination user buffer

                 CH$COPY(.dst_rab[RAB$H_RSZ], .src_ptr, 0,
                         .dst_rab[RAB$H_RSZ], .dst_ptr);

                 END
            ELSE BEGIN

                 ! If the dst file is fixed or the user specified truncation of
                 ! records (the dst MRS smaller than the src RSZ but not equal
                 ! to zero) then use the dst MRS for the dst RSZ; otherwise use
                 ! the src RSZ as the dst RSZ.

                 IF .dst_fab[FAB$V_RFM] EQL fab$k_fix               ! if fixed
                    OR (.src_rab[RAB$H_RSZ] GTR .dst_fab[FAB$H_MRS] ! if trunc
                        AND .dst_fab[FAB$H_MRS] NEQ 0)  ! and dst MRS non-zero
                 THEN dst_rab[RAB$H_RSZ] = .dst_fab[FAB$H_MRS]      ! dst MRS
                 ELSE dst_rab[RAB$H_RSZ] = .src_rab[RAB$H_RSZ];     ! src RSZ

                 src_ptr = CH$PTR(.src_rab[RAB$A_UBF], 0,
                                  .src_fab[FAB$V_BSZ]);
                 dst_ptr = CH$PTR(.dst_rab[RAB$A_UBF], 0,
                                  .dst_fab[FAB$V_BSZ]);

                 ! copy source user buffer to destination user buffer

                 CH$COPY(.src_rab[RAB$H_RSZ], .src_ptr, 0,
                         .dst_rab[RAB$H_RSZ], .dst_ptr);
                 END;

            END;

       ! For TOPS-10/20 only, force stream records to be terminated if they
       ! aren't already.

       IF ((.dst_ostype EQL XAB$K_TOPS10 OR .dst_ostype EQL XAB$K_TOPS20)
         AND .dst_fab[FAB$V_RFM] EQL fab$k_stm)
       THEN BEGIN

            LOCAL termptr;

            ! For the first record only, read the last character and see if the
            ! record is terminated by a <CR>, <LF> or <FF>.  If so, do nothing,
            ! otherwise, add <CRLF> to each record and increment the record
            ! size to indicate the change.

            IF .count EQL 0
            THEN BEGIN

                 ! from start of buffer, point to last character

                 termptr = CH$PTR(.dst_rab[RAB$A_RBF],
                                  .dst_rab[RAB$H_RSZ] - 1,
                                  .dst_fab[FAB$V_BSZ]);

                 SELECTONE CH$RCHAR_A(termptr) OF
                 SET
                 [$CHLFD,               ! Line feed
                  $CHCRT,               ! carriage return
                  $CHFFD] : ;           ! form feed

                 [OTHERWISE]:

                   ! Set flag indicating to add CRLF and increment RSZ
                   ! to compensate.

                   crlf_flag = TRUE;

                 TES;
                 END;

            IF .crlf_flag               ! add CRLF
            THEN BEGIN
                 termptr = CH$PTR(.dst_rab[RAB$A_RBF],
                                  .dst_rab[RAB$H_RSZ],
                                  .dst_fab[FAB$V_BSZ]);
                 CH$WCHAR_A ($CHCRT, termptr);
                 CH$WCHAR ($CHLFD, .termptr);
                 dst_rab[RAB$H_RSZ] = .src_rab[RAB$H_RSZ] + 2;
                 END;
            END;

       count = .count + 1;                      ! incr record count
       $PUT(RAB = .dst_rab, ERR = RMS$SIGNAL);  ! write the record

       S$BREATHE();                     ! Take a breather

       ! Clear the destination buffer

       INCR cntr FROM 0 TO DAP$K_BUFFER_SIZE_IN_WORDS - 1 DO
           dbuf[.cntr] = 0;

       END UNTIL .hell_freezes_over;    ! Condition handler catches EOF

    END;                                ! end record mode transfer processing

    DIU$_BUG                            ! can't get here unless bug

END;                                    ! End copy file routine
%SBTTL 'DO$CONFIRM - Confirm File Operation'

GLOBAL ROUTINE DO$CONFIRM (source_f : REF $FAB_DECL,
                           dest_f : REF $FAB_DECL,
                           request : REF $DIU_BLOCK,
                           count) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Print out a message for file completion.
!
! FORMAL PARAMETERS:
!
!       source_f : Addr of RMS FAB of source file
!       dest_f : Addr of RMS FAB of destination file
!       request : Address of a DIU request block which we will process
!       count : record or block count
!
! IMPLICIT INPUTS:
!
!       src_fab : source fab (used to determine remoteness)
!       dst_fab : destination fab (used to determine remoteness)
!       srccfg_xabcfg : source config XAB (use to determine source OS)
!       dstcfg_xabcfg : source config XAB (use to determine destination OS)
!       interactive : Nonzero if attached to a terminal,
!                     Zero if DIU slave job
!
!--

OWN func_one : VECTOR[DIU$K_MAX_FUNCTION]
               PRESET([DIU$K_DELETE] = PP('deleted'),
                      [DIU$K_PRINT]  = PP('printed'),
                      [DIU$K_SUBMIT] = PP('submitted')),

    func_two : VECTOR[DIU$K_MAX_FUNCTION]
               PRESET([DIU$K_COPY]   = PP('copied to'),
                      [DIU$K_APPEND] = PP('appended to'),
                      [DIU$K_RENAME] = PP('renamed to'),
                      [DIU$K_PRINT]  = PP('printed after copying to'),
                      [DIU$K_SUBMIT] = PP('submitted after copying to'));

BIND src_nam = .source_f[FAB$A_NAM] : $NAM_DECL;

LOCAL units,
      used_ostype,
      line  : $STR_DESCRIPTOR(CLASS=DYNAMIC);

$TRACE(DO$CONFIRM);

! Initialize the dynamic descriptor for the FAO output string

$STR_DESC_INIT(DESC = line, CLASS = DYNAMIC);

! Figure out what flavor machine for units: if there is no destination, use the
! source os type; if there is a destination use its os type.  NOTE: the "real"
! source and destination FABs are used here since they are the only ones with
! filled in XABs.

IF .dest_f EQL 0                        ! Was there a destination?
THEN IF .src_fab[FAB$V_REMOTE]          ! No use source - was it remote
     THEN used_ostype = .srccfg_xabcfg[XAB$B_OSTYPE]    ! Yes, get his OS type
     ELSE used_ostype = our_ostype                      ! No, use ours
ELSE IF .dst_fab[FAB$V_REMOTE]          ! There was a dest, was it remote?
     THEN used_ostype = .dstcfg_xabcfg[XAB$B_OSTYPE]    ! Yes, his OS type
     ELSE used_ostype = our_ostype;                     ! No, use ours

! Figure out units that we should report: pages, blocks, or records

units = (IF .block_mode_flag                    ! Block mode or a delete?
             OR .request[DIU$H_FUNCTION] EQL DIU$K_DELETE
         THEN IF .used_ostype EQL XAB$K_TOPS20  ! Yes, is it a 20?
              THEN PP('page')                   ! Yes, block mode 20
              ELSE PP('block')                  ! No, its block mode 10 or VMS
         ELSE PP('record'));                    ! No, record mode was used

! Construct a message to be displayed.  There are four formats that we can
! output: source and destination with units; source and destination without
! units; source with units; source without units.

IF .dest_f NEQ 0                        ! Is there a destination FAB?
THEN BEGIN                              ! Yes, type out both filenames
     BIND dst_nam = .dest_f[FAB$A_NAM] : $NAM_DECL;
     IF .count NEQ 0                    ! Were there any units to report?
     THEN $GET_FAO('!AZ !AZ!/-!_!AZ (!SL !AZ!%S)',      ! Two fabs with units
                   line,
                   .src_nam[NAM$A_RSA],
                   (.func_two[.request[DIU$H_FUNCTION]]),
                   .dst_nam[NAM$A_RSA],
                   .count,
                   .units)
     ELSE $GET_FAO('!AZ !AZ!/-!_!AZ',   ! Two FABs, no units
                   line,
                   .src_nam[NAM$A_RSA],
                   .func_two[.request[DIU$H_FUNCTION]],
                   .dst_nam[NAM$A_RSA]);

     END                                ! end of two FABs specified
ELSE IF .count EQL 0                    ! One FAB, any units?
     THEN $GET_FAO('!AZ !AZ',           ! Nope, one FAB, no units
                   line,
                   .src_nam[NAM$A_RSA],
                   .func_one[.request[DIU$H_FUNCTION]])
     ELSE $GET_FAO('!AZ !AZ (!SL !AZ!%S)',      ! One FAB with units
                   line,
                   .src_nam[NAM$A_RSA],
                   .func_one[.request[DIU$H_FUNCTION]],
                   .count,
                   .units);

! We have a message created, decide where to print it.

IF .interactive                         ! Are we running /NOQUEUE?
THEN BEGIN                              ! Yes, we are running from terminal
     $XPO_PUT(IOB=TTY, STRING=line);    ! Type it on the terminal
     S$CRIF();                          ! Go to new line 
     END
ELSE BEGIN                              ! No, we are running as slave job
     LOCAL bline : $STR_DESCRIPTOR(CLASS=DYNAMIC);
     $STR_DESC_INIT(DESC=bline, CLASS=DYNAMIC);
     $STR_COPY(TARGET=bline,
               STRING=$STR_CONCAT(%CHAR(13,10,%C'-',9),
                                  line));
     LJ$UTXT(bline);                    ! Put in log file
     IP_STATUS(DIU$_TEXT,0,bline);      !  and in system log file
     $XPO_FREE_MEM(STRING=bline);       ! Free up the memory
     END;

$XPO_FREE_MEM(STRING=line);             ! Be neat

END;                                    ! End of DO$CONFIRM
%SBTTL 'DO$$LOAD_BLOCKS - Process Single Group Of Tags'

ROUTINE DO$$LOAD_BLOCKS (p_fab, p_rab, p_tag_ptr) : NOVALUE =
!++
! FUNCTIONAL DESCRIPTION:
!
!       Internal routine to process a single group of tags.
!
! FORMAL PARAMETERS:
!
!       p_fab : RMS FAB structure
!       p_rab : RMS RAB structure
!       p_tag_ptr : pointer to tag
!--
BEGIN
BIND fab = .p_fab : $FAB_DECL,
     typ = .fab[fab$a_typ] : $TYP_DECL,
     rab = .p_rab : $RAB_DECL,
     tag_ptr = .p_tag_ptr;

LOCAL tag,
      tln,
      value,
      status,
      val_desc : $STR_DESCRIPTOR();

MACRO $$RMS_VALUE(pointer, item) = 
      BEGIN
      LOCAL tln;

      ! Create a descriptor for section containing value

      tln = CH$RCHAR_A(pointer);
      $STR_DESC_INIT(DESC = val_desc, STRING = (.tln, .pointer));

      pointer = CH$PLUS(.pointer, .tln);        ! Skip over value

      ! Convert it to binary

      IF NOT (status = $STR_BINARY(STRING = val_desc, RESULT = value))
      THEN SIGNAL(.status); 

      item = .value;               ! Drop it into the RMS block 

      END%;

MACRO $$RMS_MASK(pointer, item) =
      BEGIN
      LOCAL tln;

      ! Create a descriptor for section containing value

      tln = CH$RCHAR_A (pointer);
      $STR_DESC_INIT (DESC = val_desc, STRING = (.tln, .pointer));

      pointer = CH$PLUS (.pointer, .tln);       ! Skip over value

      ! Convert it to binary

      IF NOT (status = $STR_BINARY (STRING = val_desc, RESULT = value))
      THEN SIGNAL(.status); 

      ! Handle NOT bits as well.  (Nothing sets the sign bit)

      IF (.value GEQ 0)
      THEN item = .item OR .value       ! OR it into RMS field
      ELSE item = .item AND (.value);   ! AND it out of RMS field
      END%;                          

UNTIL (tag = CH$RCHAR_A(tag_ptr)) EQL $ETG DO
  BEGIN

  $TRACE_FAO('DO$$LOAD_BLOCKS Tag found is !3SL',.tag);

  SELECTONE .tag OF
  SET
  [DIU$K_FAB_BSZ] : $$RMS_VALUE(tag_ptr,fab[FAB$V_BSZ]); ! byte size
  [DIU$K_FAB_FOP] : $$RMS_MASK (tag_ptr,fab[FAB$H_FOP]); ! file options
  [DIU$K_FAB_FSZ] : $$RMS_VALUE(tag_ptr,fab[FAB$B_FSZ]); ! fixed hdr size
  [DIU$K_FAB_ORG] : $$RMS_VALUE(tag_ptr,fab[FAB$V_ORG]); ! Organization
  [DIU$K_FAB_RAT] : $$RMS_MASK (tag_ptr,fab[FAB$H_RAT]); ! Rec attributes
  [DIU$K_FAB_RFM] : $$RMS_VALUE(tag_ptr,fab[FAB$V_RFM]); ! Record format
  [DIU$K_FAB_MRS] : $$RMS_VALUE(tag_ptr,fab[FAB$H_MRS]); ! Max rec size
  [DIU$K_FAB_FAC] : $$RMS_MASK (tag_ptr,fab[FAB$H_FAC]); ! File access 
  [DIU$K_RAB_RSZ] : $$RMS_VALUE(tag_ptr,rab[RAB$H_RSZ]); ! Record size
  [DIU$K_DIU_FILE_DATATYPE] : $$RMS_VALUE(tag_ptr,typ[TYP$H_CLASS]); ! Datatype
  [OTHERWISE] : SIGNAL(DIU$_BUG);

  TES;      ! end of tag application code

  END;      ! end until no more tags for this file block

END;                                    ! End of routine  DO$$LOAD_BLOCKS
%SBTTL 'DO$LOAD_BLOCKS - Load RMS Blocks'

ROUTINE DO$LOAD_BLOCKS (p_rab, p_buf, p_ptr, p_len, p_fnm) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       This routine will load the specified RMS blocks with any RMS attributes
!       specified in the tag buffer.  The filename is always loaded.  In many
!       cases, attributes such as RAT, RFM, ORG and others are loaded as well.
!
! FORMAL PARAMETERS:
!
!       p_rab - Address of $RAB which we will load and which points to other
!               RMS structures such as XAB's that we can modify.
!
!       p_buf - Address of tags buffer which we need to extract filenames and
!               attributes.
!
!       p_ptr - CH$PTR to current position in tags buffer.  This should always
!               be the byte which begins the filespec.
!
!       p_len - Length of filespec.  This is used so we can traverse tags
!               information following filespec.
!
!       p_fnm - Address of the file name.
!
! COMPLETION CODES:
!
!       DIU$_NORMAL    - Successful load of tags information
!       DIU$_BUG       - SIGNAL'd error, inconsistency in tags buffer
!
! SIDE EFFECTS:
!
!       RMS structures are modified. 
!--
BIND len = .p_len,
     fnz = .p_fnm,
     buf = .p_buf,
     ptr = .p_ptr,
     rab = .p_rab : $RAB_DECL,
     fab = .rab[RAB$A_FAB] : $FAB_DECL,
     nam = .fab[FAB$A_NAM] : $NAM_DECL,
     xabsum = .fab[FAB$A_XAB] : $XABSUM_DECL,
     xabcfg = .xabsum[XAB$A_NXT] : $XABCFG_DECL,
     xabdat = .xabcfg[XAB$A_NXT] : $XABDAT_DECL;

LOCAL tag_ptr,
      fnz_ptr;

$TRACE(DO$LOAD_BLOCKS);

tag_ptr = CH$PTR(buf);

DO$$LOAD_BLOCKS(fab, rab, tag_ptr);     ! load individual blocks

! copy filename, make it ASCIZ and point FAB to it

fnz_ptr = CH$PTR(fnz);                  ! make char pointer to file name
CH$FILL(0,NAM$K_MAXRSS,.fnz_ptr);
CH$MOVE(.len,.ptr,.fnz_ptr);
fnz_ptr = CH$PLUS(.fnz_ptr,.len+1);     ! move past the tags
CH$WCHAR_A(0,fnz_ptr);                  ! make the file name it ASCIZ
fab[FAB$A_FNA] = CH$PTR(fnz);           ! copy pointer to it into the FAB

tag_ptr = CH$PLUS(.ptr, .len);          ! point to 1st tag id after filespec

DO$$LOAD_BLOCKS(fab, rab, tag_ptr);     ! load individual tags

END;     ! End of routine DO$LOAD_ BLOCKS
%SBTTL 'DO$ATTRIBUTE_COPY - Copy Input File Attributes to Destination'

ROUTINE DO$ATTRIBUTE_COPY(src_rab : REF $RAB_DECL,
                          dst_rab : REF $RAB_DECL) : NOVALUE = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!       This routine will copy over the date/time fields from the source date
!       XAB to the destination date XAB if there is no transform, and set the
!       record attribute defaults.
!
! FORMAL PARAMETERS:
!
!       src_rab - Address of source file $RAB which points to other RMS
!                 structures such as XAB's that we can copy.
!
!       dst_rab - Address of destination file $RAB which points to other RMS
!                 structures we will modify.
!
!
! COMPLETION CODES:
!
!       DIU$_NORMAL    - Successful load of tags information
!       DIU$_BUG       - SIGNAL'd error, inconsistency in tags buffer
!
!--

BIND src_fab = .src_rab[RAB$A_FAB] : $FAB_DECL,
     src_xabsum = .src_fab[FAB$A_XAB] : $XABSUM_DECL,
     src_xabcfg = .src_xabsum[XAB$A_NXT] : $XABCFG_DECL,
     src_xabdat = .src_xabcfg[XAB$A_NXT] : $XABDAT_DECL,
     dst_fab = .dst_rab[RAB$A_FAB] : $FAB_DECL,
     dst_xabsum = .dst_fab[FAB$A_XAB] : $XABSUM_DECL,
     dst_xabcfg = .dst_xabsum[XAB$A_NXT] : $XABCFG_DECL,
     dst_xabdat = .dst_xabcfg[XAB$A_NXT] : $XABDAT_DECL;

$TRACE('DO$ATTRIBUTE_COPY');

IF .rtrans EQL 0                        ! if there is no transform
THEN BEGIN                              ! copy contents of date XAB
     dst_xabdat[XAB$G_CDT] = .src_xabdat[XAB$G_CDT];    ! Creation date/time
     dst_xabdat[XAB$G_RDT] = .src_xabdat[XAB$G_RDT];    ! Revision date/time
     dst_xabdat[XAB$G_EDT] = .src_xabdat[XAB$G_EDT];    ! Expiration date/time
     END;

! Set the destination record attribute if not already specified.  If
! the file is not going to be on a TOPS-10/20 system then set the
! record attribute to carriage return carriage control.

IF .dst_fab[FAB$H_RAT] EQL 0            ! default for TOPS-10/20 is nil
THEN IF ((.dst_xabcfg[XAB$B_FILESYS] NEQ XAB$K_FILESYS_TOPS10)
         AND (.dst_xabcfg[XAB$B_FILESYS] NEQ XAB$K_FILESYS_RMS20)
         AND (.dst_xabcfg[XAB$B_FILESYS] NEQ XAB$K_FILESYS_TOPS20)
         AND (.dst_xabcfg[XAB$B_FILESYS] NEQ 0))
     THEN dst_fab[FAB$V_CR] = 1;        ! VAX/PRO default is CR carriage ctl

RETURN;

END;   ! End routine DO$ATTRIBUTE_COPY
%SBTTL 'DO$KEY_ACTION - Parse/Process KEY Information'

ROUTINE DO$KEY_ACTION (request : REF $DIU_BLOCK) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Process the key command line information stored in the request
!       block and build the XABKEY chain from the information.
!
! FORMAL PARAMETERS:
!
!       None.
!
! COMPLETION CODES:
!
!       May signal one of the following:
!          DIU$_BUG
!          DIU$_KEY_NAME_INVALID
!          DIU$_KEY_SIZE_INVALID
!          DIU$_KEY_DATATYPE_INVALID
!          DIU$_KEY_DTP_CONFLICT
!          DIU$_SEGMENT_KEY_INVALID
!          DIU$_KEY_OPTIONS_INVALID
!
! SIDE EFFECTS:
!
!       KEYXABs will be hooked onto the XAB chain which is hooked
!       onto the dst_fab.
!
!--
EXTERNAL ROUTINE PRODUCE_FQN,
                 FIND_MATCHING_MEMBER,
                 FREE_STRINGLIST;

LOCAL tfqn : INITIAL (0),
      key_count : INITIAL (0),
      key_opt_switch : INITIAL (0),
      member : REF crx_member,
      segment_flag : INITIAL (0),
      seg_count : INITIAL (0),
      status : INITIAL (0),
      strstat : INITIAL (0),
      keyline : $STR_DESCRIPTOR(),
      keytoken : $STR_DESCRIPTOR (STRING = (0, 0)),
      keydelim : INITIAL (0),
      xk_root : REF $xabkey_decl,       ! xabkey root
      xk_curr : REF $xabkey_decl,       ! xabkey current structure address
      xk_prev : REF $xabkey_decl;       ! xabkey previous structure address

$STR_DESC_INIT (DESCRIPTOR = keyline, CLASS = DYNAMIC,
                STRING = (0, 0));       ! init descriptor

! Copy the key info from the request block into our local descriptor, and make
! it all uppercase.  This is necessary because the field names in the record
! description tree are always in uppercase, and in routine FIND_MATCHING_MEMBER
! we try to match the key field name (typed in by the user) to a field in the
! record description tree.  Since the "match" is case sensitive, so we'll
! forceour names into upperase also.  So, copy key switch information into our
! descriptor and uppercase it.

$STR_COPY (STRING = $STR_FORMAT ((.request [DIU$H_KEY_SWITCH],
                                  CH$PTR (request [DIU$T_KEY_SWITCH])),
                                 UP_CASE),      ! uppercase it please
           TARGET = keyline);

$XPO_GET_MEM (FULLWORDS = xab$k_keylen, ! get mem for 1st XABKEY
              FILL = 0,
              RESULT = xk_root);

$XABKEY_INIT(XAB = .xk_root, KREF = 0); ! init 1st XABKEY

xk_curr = .xk_root;                     ! set up chain...

seg_count = 0;                          ! read 1st token so init this to 0

DO BEGIN
   LOCAL k2 : $STR_DESCRIPTOR();

   $STR_DESC_INIT (DESCRIPTOR = k2, CLASS = DYNAMIC,
                   STRING = (0, 0));    ! init temporary descriptor

   ! Increment the keyline descriptor up past the previously parsed
   ! token...  If it is the first time through this loop, keydelim
   ! will still be 0, and we don't want to do this...

   IF .keydelim NEQ 0
   THEN BEGIN
        $STR_COPY(STRING=((.keyline[STR$H_LENGTH]-(.keytoken[STR$H_LENGTH]+1)),
                          CH$PLUS (.keyline [STR$A_POINTER],
                                   (.keytoken[STR$H_LENGTH]+1))),
                  TARGET = k2);

        $STR_COPY (STRING = k2, TARGET = keyline);
        $XPO_FREE_MEM (STRING = k2);    ! done with this

        END;

   strstat = $STR_SCAN (STRING = keyline,       ! scan key switch info
                        STOP = '+,:',           ! stop on "+", ",", ":"
                        SUBSTRING = keytoken,   ! save the token here
                        DELIMITER = keydelim);  ! save the delimiter also


   IF NOT .key_opt_switch               ! token is fld name (not key opt swtch)
   THEN BEGIN

        LOCAL dattyp : data_type_sep,
              tkeytok : $STR_DESCRIPTOR (STRING = (0, 0)),
              rms_dattyp : INITIAL (0),
              siz : INITIAL (0),
              pos : INITIAL (0),
              bytsiz : INITIAL(0),       ! byte size
              bytes_per_wd;

        ! The PRODUCE_FQN routine (called below) clears the string descr
        ! passed to it, but we want to keep using the keytoken, so make
        ! a copy of it to pass to PRODUCE_FQN...

        $STR_DESC_INIT (DESCRIPTOR = tkeytok, CLASS = DYNAMIC,
                        STRING = (0, 0));
        $STR_COPY (STRING = keytoken, TARGET = tkeytok);

        ! Expand the key field name into a fully qualified name

        status = PRODUCE_FQN (tkeytok, tfqn);
        IF NOT .status
        THEN BEGIN
             FREE_STRINGLIST (.tfqn);
             SIGNAL (DIU$_BUG)          ! produce_fqn should always return true
             END;

        ! Find member node which matches the fqn...

        member = 0;                     ! initialize to zero
        status = FIND_MATCHING_MEMBER (.tfqn, .ddescr, member, 0);
        IF NOT .status
        THEN SIGNAL (DIU$_KEY_NAME_INVALID, 1, keytoken, 0);    ! no match...

        ! We are now done with the info in tfqn, so free up the memory

        FREE_STRINGLIST (.tfqn);        ! free the memory
        tfqn = 0;                       ! reset to zero

        dattyp = .member [CRM$W_DATATYPE];      ! datatype is always DIL here

        ! for each datatype, set the byte size and corresponding RMS datatype

        SELECTONE .dattyp OF
          SET
          [DIX$K_DT_ASCII_7, DIX$K_DT_ASCIZ, DIX$K_DT_DN7LO, DIX$K_DT_DN7LS,
           DIX$K_DT_DN7TO, DIX$K_DT_DN7TS, DIX$K_DT_DN7U] :
                 BEGIN
                 bytsiz = 7;
                 rms_dattyp = xab$k_stg;        ! String data
                 IF (.member [CRM$L_STRING_UNITS] GTR 256)
                 THEN SIGNAL (DIU$_KEY_SIZE_INVALID)
                 ELSE siz = .member[CRM$L_STRING_UNITS];
                 END;

          [DIX$K_DT_ASCII_8, DIX$K_DT_EBCDIC_8, DIX$K_DT_DN8LO, DIX$K_DT_DN8LS,
           DIX$K_DT_DN8TO, DIX$K_DT_DN8TS, DIX$K_DT_DN8U] :
                 BEGIN
                 bytsiz = 8;
                 rms_dattyp = xab$k_stg;        ! String data
                 IF (.member [CRM$L_STRING_UNITS] GTR 256)
                 THEN SIGNAL (DIU$_KEY_SIZE_INVALID)
                 ELSE siz = .member[CRM$L_STRING_UNITS];
                 END;

          [DIX$K_DT_EBCDIC_9, DIX$K_DT_DN9LO, DIX$K_DT_DN9LS,
           DIX$K_DT_DN9TO, DIX$K_DT_DN9TS, DIX$K_DT_DN9U] :
                 BEGIN
                 bytsiz = 9;
                 rms_dattyp = xab$k_ebc;        ! EBCDIC data
                 IF (.member [CRM$L_STRING_UNITS] GTR 256)
                 THEN SIGNAL (DIU$_KEY_SIZE_INVALID)
                 ELSE siz = .member[CRM$L_STRING_UNITS];
                 END;

          [DIX$K_DT_SIXBIT, DIX$K_DT_DN6LO, DIX$K_DT_DN6LS,
           DIX$K_DT_DN6TO, DIX$K_DT_DN6TS, DIX$K_DT_DN6U] :
                 BEGIN
                 bytsiz = 6;
                 rms_dattyp = xab$k_six;        ! SIXBIT data
                 IF (.member [CRM$L_STRING_UNITS] GTR 256)
                 THEN SIGNAL (DIU$_KEY_SIZE_INVALID)
                 ELSE siz = .member[CRM$L_STRING_UNITS];
                 END;

          [DIX$K_DT_SBF128] :
                 ! DAP doesn't support this datatype...
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_SBF16] :
                 ! DAP supports this, but RMS-20 doesn't...
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_SBF32] : 
                 BEGIN
                 bytsiz = 8;
                 rms_dattyp = xab$k_in4;        ! 4 BYTE INTEGER data
                 siz = 4;
                 END;

          [DIX$K_DT_SBF36] :
                 BEGIN
                 bytsiz = 36;
                 rms_dattyp = xab$k_in4;        ! 1 WORD INTEGER data
                 siz = 1;
                 END;

          [DIX$K_DT_SBF64] :
                 BEGIN
                 bytsiz = 8;
                 rms_dattyp = xab$k_in8;        ! 8 BYTE INTEGER data
                 siz = 8;
                 END;

          [DIX$K_DT_SBF72] :
                 BEGIN
                 bytsiz = 36;
                 rms_dattyp = xab$k_in8;        ! 2 WORD INTEGER data
                 siz = 2;
                 END;

          [DIX$K_DT_SBF8] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_UBF16] :
                 ! DAP supports this, but RMS-20 doesn't...
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_UBF32] :
                 BEGIN
                 bytsiz = 8;
                 rms_dattyp = xab$k_bn4;        ! 4 BYTE UNSIGNED INTEGER data
                 siz = 4;
                 END;

          [DIX$K_DT_UBF8] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_UBF128] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_UBF36] :
                 BEGIN
                 bytsiz = 36;
                 rms_dattyp = xab$k_bn4;        ! UNSIGNED 1 WORD INTEGER
                 siz = 1;
                 END;

          [DIX$K_DT_UBF64] :
                 ! DAP supports this, but RMS-20 doesn't...
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_UBF72] :
                 ! DAP supports this, but RMS-20 doesn't...
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_D_FLOAT] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_F_FLOAT] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_FLOAT_36] :
                 BEGIN
                 bytsiz = 36;
                 rms_dattyp = xab$k_fl1;        ! 1 WORD FLOATING data
                 siz = 1;
                 END;

          [DIX$K_DT_FLOAT_72] :
                 BEGIN
                 bytsiz = 36;
                 rms_dattyp = xab$k_fl2;        ! 2 WORD FLOATING data
                 siz = 2;
                 END;

          [DIX$K_DT_G_FLOAT] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_G_FLOAT72] :
                 BEGIN
                 bytsiz = 36;
                 rms_dattyp = xab$k_gfl;        ! GFLOATING data
                 siz = 2;
                 END;

          [DIX$K_DT_H_FLOAT] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_D_CMPLX] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_F_CMPLX] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_F_CMPLX36] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_G_CMPLX] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_H_CMPLX] :
                 ! DAP doesn't support this datatype
                 SIGNAL (DIU$_KEY_DATATYPE_INVALID);

          [DIX$K_DT_PD8] :
                 BEGIN
                 bytsiz = 8;
                 rms_dattyp = xab$k_pac;        ! PACKED DECIMAL data
                 IF (.member [CRM$W_DIGITS] GTR 256)
                 THEN SIGNAL (DIU$_KEY_SIZE_INVALID)
                 ELSE siz = .member [CRM$W_DIGITS];
                 END;

          [DIX$K_DT_PD9] :
                 BEGIN
                 bytsiz = 9;
                 rms_dattyp = xab$k_pac;        ! PACKED DECIMAL data
                 IF (.member [CRM$W_DIGITS] GTR 256)
                 THEN SIGNAL (DIU$_KEY_SIZE_INVALID)
                 ELSE siz = .member [CRM$W_DIGITS];
                 END;

          [OTHERWISE] : SIGNAL (DIU$_BUG);   ! should never happen

          TES;

          ! Set the size for the current segment

          SELECTONE .seg_count OF
            SET [0] : xk_curr [XAB$H_SIZ0] = .siz;
                [1] : xk_curr [XAB$H_SIZ1] = .siz;
                [2] : xk_curr [XAB$H_SIZ2] = .siz;
                [3] : xk_curr [XAB$H_SIZ3] = .siz;
                [4] : xk_curr [XAB$H_SIZ4] = .siz;
                [5] : xk_curr [XAB$H_SIZ5] = .siz;
                [6] : xk_curr [XAB$H_SIZ6] = .siz;
                [7] : xk_curr [XAB$H_SIZ7] = .siz;
            TES;

          ! determine the position based on dest system type

          IF (.dst_ostype EQL XAB$K_TOPS10 OR .dst_ostype EQL XAB$K_TOPS20)
          THEN BEGIN
               bytes_per_wd = %BPVAL / .bytsiz;
               ! figure out byte offset to beginning of key field
               pos =
                  (.member[CRM$L_MEMBER_OFFSET]/%BPVAL) * .bytes_per_wd
                    + (.member[CRM$L_MEMBER_OFFSET] MOD %BPVAL)/.bytsiz;
               END
          ELSE                          ! byte size is always 8...
               pos = .member [CRM$L_MEMBER_OFFSET] / 8;

          ! set the position for current segment

          SELECTONE .seg_count OF
            SET [0] : xk_curr [XAB$H_POS0] = .pos;
                [1] : xk_curr [XAB$H_POS1] = .pos;
                [2] : xk_curr [XAB$H_POS2] = .pos;
                [3] : xk_curr [XAB$H_POS3] = .pos;
                [4] : xk_curr [XAB$H_POS4] = .pos;
                [5] : xk_curr [XAB$H_POS5] = .pos;
                [6] : xk_curr [XAB$H_POS6] = .pos;
                [7] : xk_curr [XAB$H_POS7] = .pos;
            TES;

        ! If this is a multi-segmented key, then make sure the datatypes of all
        ! of the fields specified are the same.  If we are processing the first
        ! segment (or this is a single segment key) then just save the datatype
        ! of the field in the key XAB.

        IF .seg_count NEQ 0
        THEN ( IF .rms_dattyp NEQ .xk_curr [xab$v_dtp]
               THEN SIGNAL (DIU$_KEY_DTP_CONFLICT) )
        ELSE xk_curr [xab$v_dtp] = .rms_dattyp; 

        ! set the key of reference

        xk_curr [xab$b_ref] = .key_count;

        ! If a multi-segment key is being used, make sure that the datatype of
        ! the key is valid for multi-segmented keys.  Packed decimal,
        ! floating-point and integer keys are not valid for multi-segment keys.

        IF .seg_count NEQ 0             ! if this is a mulit-segment key
        THEN SELECTONE .rms_dattyp OF
             SET
             [xab$k_pac, xab$k_in4, xab$k_fl1, xab$k_fl2,
              xab$k_gfl, xab$k_in8, xab$k_bn4, xab$k_uin] :
                    SIGNAL (DIU$_SEGMENT_KEY_INVALID);
             [xab$k_stg, xab$k_ebc, xab$k_six, xab$k_as8] : ;   ! do nothing
             TES;

        END

   ELSE BEGIN                           ! key_opt_switch is on

        ! determine which keytoken it is and do the right thing!!

        IF $STR_EQL (STRING1 = keytoken,
                     STRING2 = '2')     ! allow changes
        THEN xk_curr[XAB$V_CHG] = 1
        ELSE IF $STR_EQL (STRING1 = keytoken,
                          STRING2 = '3')        ! allow duplicates
             THEN xk_curr[XAB$V_DUP] = 1
             ELSE IF $STR_EQL (STRING1 = keytoken,
                               STRING2 = '4')   ! disallow changes
                  THEN xk_curr[XAB$V_CHG] = 0
                  ELSE IF $STR_EQL (STRING1 = keytoken,
                                    STRING2 = '5')      ! disallow duplicates
                       THEN xk_curr[XAB$V_DUP] = 0;

        ! VMS doesn't support alternate keys with NODUPLICATES and CHANGES.

        IF NOT .xk_curr[XAB$V_DUP] AND .xk_curr[XAB$V_CHG]    
          AND .dst_ostype EQL XAB$K_VMS
        THEN SIGNAL(DIU$_KEY_OPTIONS_INVALID);

        END;

   ! The delimiter determines what we are processing next: either another
   ! segment of the current key, a new key, or key option switch.

   SELECTONE .keydelim OF
      SET
      [%C'+'] :                         ! process another key segment next
           BEGIN
           segment_flag = 1;            ! we are processing a segment
           seg_count = .seg_count + 1;  ! increment segment count
           END;

      [%C','] :
           BEGIN                        ! process a new key next
           xk_prev = .xk_curr;
           $XPO_GET_MEM (FULLWORDS = xab$k_keylen,      ! get mem for XABKEY
                         FILL = 0,
                         RESULT = xk_curr);
           $XABKEY_INIT(XAB = .xk_curr, KREF = 0);      ! init XABKEY
           xk_prev [XAB$A_NXT] = .xk_curr;      ! hook new XABKEY into chain
           key_opt_switch = 0;          ! turn off key option switch
           seg_count = 0;               ! this is 1st segment of key
           segment_flag = 0;            ! not processing multi-seg key yet
           key_count = .key_count + 1;  ! processing next key so incr count
           END;

      [%C':'] :                         ! process a key option switch next
           key_opt_switch = 1;          ! turn on key option switch

      TES;

   END

UNTIL .strstat EQL STR$_END_STRING;     ! stop after last token parsed

dstdat_xabdat[XAB$A_NXT] = .xk_root;    ! hook first XABKEY onto XAB chain

END;                                    ! end DO$KEY_ACTION routine
%SBTTL 'DO$BYPASS - Determine If RMS Error Is Bypassable'

GLOBAL ROUTINE DO$BYPASS (fab : REF $FAB_DECL) = 
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
!       Look at the RMS STS and STV values, and determine if we can bypass or
!       just skip the file.  If so, print a message and return true.  If not,
!       return false.
!
! FORMAL PARAMETERS:
!
!       fab : address of a FAB of which to check the status
!
! SIDE EFFECTS:
!
!       Message could be written to log file
!
! ROUTINE VALUE
!
!       True   - Error is bypassable
!       False  - Error is not bypassable
!--
LOCAL length : INITIAL(0),
      ret_value : INITIAL(FALSE),
      file : $STR_DESCRIPTOR(),
      msg_text : $STR_DESCRIPTOR(),
      msg_buf : VECTOR[CH$ALLOCATION(256)];

BIND nam = .fab[FAB$A_NAM] : $NAM_DECL;

$TRACE('DO$BYPASS');

! Determine if the error is recoverable or skippable.

ret_value = (SELECTONE .fab[FAB$H_STS] OF
             SET
             [RMS$_FLK]  : TRUE;        ! File is locked
             [RMS$_COF]  : TRUE;        ! Cannot open file (OPENF failed)
             [RMS$_PRV]  : TRUE;        ! Protection violation
             [OTHERWISE] : FALSE;       ! any other is not bypassable
             TES);

IF .ret_value 
THEN BEGIN
     $STR_DESC_INIT(DESC = msg_text,    ! init the target string
                    STRING = (256, CH$PTR(msg_buf)));

     ! Create a string descriptor for the filespec... wherever it is!

     IF .nam[NAM$H_RSL] NEQ 0           ! use NAM block resultant string
     THEN $STR_DESC_INIT(DESC = file,   !  if available
                         STRING = (.nam[NAM$H_RSL],
                                   .nam[NAM$A_RSA]))
     ELSE IF .nam[NAM$H_ESL] NEQ 0              ! else use NAM block ESA string
          THEN $STR_DESC_INIT(DESC = file,      !  if available
                              STRING = (.nam[NAM$H_ESL],
                                        .nam[NAM$A_ESA]))
          ELSE IF (length = ASCIZ_LEN(.fab[FAB$A_FNA])) NEQ 0   ! else use FAB
               THEN $STR_DESC_INIT(DESC = file,                 !  file name
                                   STRING = (.length,.fab[FAB$A_FNA]))
               ELSE $STR_DESC_INIT(DESC = file, STRING = '-no file-');

     R$ERRMSG(.fab[FAB$H_STS],          ! Primary status field
              .fab[FAB$H_STV],          ! Secondary status field
              file,                     ! Filename
              msg_text,                 ! Return message text
              length);                  ! Return length

     msg_text[STR$H_LENGTH] = .length;

     $MSG_FAO( '!/Bypassing !AS!/', file );

     ! Print our reason for bypassing the file..

     IF .interactive
     THEN BEGIN
          $XPO_PUT (IOB = TTY, STRING = msg_text);
          S$CRIF();
          END
     ELSE BEGIN

          ! Log this in user log file, and send IPCF to master job

          LJ$UTXT (msg_text);           ! Put in log file
          IP_STATUS (DIU$_TEXT, 0, msg_text);
          END;

     END;                               ! end of bypass block

RETURN .ret_value;                      ! Return the right thing...

END;                                    ! end DO$BYPASS
%SBTTL 'DO$HANDLER - Condition Handler For DIUDO Signals'

GLOBAL ROUTINE DO$HANDLER (signal_args,mech_args,enable_args) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION
!
!       Condition handler for requests in DIU$DO.
!
! FORMAL PARAMETERS
!
!       signal_args  : addr of vector of SIGNAL arguments,
!       mech_args    : addr of mechanism vector,
!       enable_args  : args passed when this handler was established
!
!                  [0]: Number of arguments in vector
!                  [1]: Source FAB
!                  [2]: Destination FAB (optional)
!                  [3]: Source RAB (Optional)
!                  [4]: Destination RAB (Optional)
!                  [5]: Don't delete the destination on failure (Optional)
!
! COMPLETION CODES
!
!       0  : Resignal 
!       1  : Continue
!
! SIDE EFFECTS
!
!       Buffers associated with RAB's will be freed if the addresses of the
!       RABs are passed and the SS$_UNWIND is signalled.
!
!--

MAP signal_args : REF VECTOR,
    mech_args : REF VECTOR,
    enable_args : REF VECTOR;

BIND source = ..enable_args[1]: $FAB_DECL,
     destination = ..enable_args[2]: $FAB_DECL;

LOCAL code,
      code2 : INITIAL (0),
      addtext : $STR_DESCRIPTOR(CLASS=DYNAMIC),
      arglist,
      severity;

OWN saved_code;               ! If unwinding, this becomes the returned value

$TRACE(DO$HANDLER);

IF source EQL 0                                 ! defend against being called
THEN BEGIN                                      !  before we're set up
     mech_args[%BLISS36(1)] = .signal_args[1];  ! return signalled status
     RETURN STS$K_RESIGNAL;
     END;

code = .signal_args[1];
code2 = (IF .signal_args[0] GTR 1
         THEN .signal_args[2]
         ELSE 0);

IF .signal_args[1] NEQ SS$_UNWIND       ! If we're not unwinding, save the code
THEN saved_code = .signal_args[1];

severity = .(signal_args[1])<0,3>;      ! Corporate standard

SELECT .signal_args[1] OF
SET
   [RMS$K_ERR_MIN TO RMS$K_ERR_MIN+%O'7777']:   ! RMS-20 predates
                 severity=STS$K_ERROR;          ! the standard

   [RMS$K_SUC_MIN TO RMS$K_SUC_MIN+%O'17']:   
                 BEGIN
                 severity   = STS$K_NORMAL;       
                 saved_code = DIU$_NORMAL;
                 END;

   [%O'600000' TO %O'677777'] :  severity = STS$K_ERROR;        ! JSYS error

   [RMS$_EOF, RMS$_NMF,DIU$_REQUEST_COMPLETED]:
                 BEGIN
                 IF .enable_args[0] GEQ 2
                 THEN BEGIN
                      destination[FAB$V_DRJ]=0;
                      $CLOSE(FAB=dst_fab);
                      END;
                 saved_code = DIU$_REQUEST_COMPLETED;
                 RETURN SETUNWIND();
                 END;

   [SS$_UNWIND]:
                 BEGIN
                 source[FAB$V_DRJ]=0;   ! Do release JFN & everything
                 $CLOSE(FAB=src_fab);   ! Try to close the source file

                 IF .dst_fab NEQ 0      ! if we have a dst_fab
                 THEN BEGIN
                      dst_fab[FAB$V_DRJ] = 0;   ! release JFNs and
                      $CLOSE (FAB = dst_fab);   ! close files
                      END;

                 ! Cause establisher to return correct code to caller
                 mech_args[%BLISS36(1)] = .saved_code;

                 RETURN STS$K_NORMAL;
                 END;

    TES;                                ! select of error codes

    $STR_DESC_INIT(DESC=addtext,        ! init message string 
                   CLASS=DYNAMIC);

    IF (.signal_args[0] GEQ 4)                  ! If we have that many args
    AND (.signal_args[2]+3 EQL .signal_args[0]) ! and the second is fao count
    THEN BEGIN

         ! Handle VMS-ish form:  (STS,#-Fao-Args,Fao-args ...,STV) 

         code2=.signal_args[.signal_args[2]+3]; ! STV is arg after FAO blk
         arglist=signal_args[2];                ! pass vector to routine
         END
    ELSE BEGIN
         IF (.signal_args[0] GEQ 3)     ! Were we passed a block?
            AND (.signal_args[3] NEQ 0)
         THEN BEGIN

              ! look for a FAB from which to get a file name

              LOCAL blk: REF $RAB_DECL,
                    current : $STR_DESCRIPTOR (CLASS=BOUNDED),
                    temp : $STR_DESCRIPTOR (CLASS=DYNAMIC);

              blk = .signal_args[3];    ! this may be it
              SELECT .blk[RAB$H_BID] OF ! let's look at it
                SET
                [FAB$K_BID]:
                    BEGIN
                    E$FILES(.blk,addtext);
                    $STR_DESC_INIT(DESC = current, CLASS = BOUNDED,
                                   STRING = (.addtext[STR$H_LENGTH],
                                             .addtext[STR$A_POINTER]));
                    $STR_DESC_INIT(DESC = temp,CLASS = DYNAMIC);
                    MOVE_WITHOUT_PASSWORD(current, temp);
                    $STR_COPY(STRING = temp, TARGET = addtext);
                    END;
                [RAB$K_BID]:
                    BEGIN
                    E$FILES(.blk[RAB$A_FAB],addtext);
                    $STR_DESC_INIT(DESC = current, CLASS = BOUNDED,
                                   STRING = (.addtext[STR$H_LENGTH],
                                             .addtext[STR$A_POINTER]));
                    $STR_DESC_INIT(DESC = temp, CLASS = DYNAMIC);
                    MOVE_WITHOUT_PASSWORD(current, temp);
                    $STR_COPY(STRING = temp, TARGET = addtext);
                    END;
                TES;                    ! Get the filespec from the FAB
              END;

        IF (.signal_args[0] GEQ 4)      ! if passed additional text, use it
            AND (.signal_args[3] EQL 0) ! unless RMS stuff was requested
            AND (.signal_args[4] NEQ 0)
        THEN $STR_COPY (TARGET = addtext,
                        STRING = .signal_args[4]);

         arglist=addtext;
         END;


    ! Tell someone about it

    IF .interactive
    THEN
        DIU$MESSAGE(.code,.code2,.arglist,FALSE) ! Type on terminal (only)
    ELSE
        BEGIN

        ! Log this in user log file, and send IPCF to master job

        LJ$ULOG(.code,.code2,.arglist); ! write condition to user log file
        IP_STATUS(.code,.code2,.arglist);
        END;

    $XPO_FREE_MEM(STRING=addtext);

    CASE .SEVERITY FROM 0 TO 7 OF
         SET
         [STS$K_ERROR, STS$K_WARNING]  : SETUNWIND();
         [STS$K_NORMAL, STS$K_INFO]    : RETURN STS$K_NORMAL;
         [STS$K_FATAL,INRANGE]         : ;
         TES;

    STS$K_RESIGNAL

END;                                    ! End of DO$HANDLER

END                                     ! End of module
ELUDOM