Trailing-Edge
-
PDP-10 Archives
-
CFS_TSU04_19910205_1of1
-
update/t20src/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