From:	MERC::"uunet!CRVAX.SRI.COM!RELAY-INFO-VAX"  9-MAR-1993 15:48:18.35
To:	Info-VAX@KL.SRI.COM
CC:	
Subj:	FIDDEL.001-OF-001

Ooops.  Here is the VMS_SHARE file containing FIDDEL.FOR, FIDDEL_CLD.CLD,
and MAKE.COM

Good luck,
-Shawn

-------------------------------------------------------------------------------
Shawn A. Clifford, System Manager | Internet: sysop@robot.nuceng.ufl.edu
Nuclear Engineering Sciences      |		sac@eng.ufl.edu
University of Florida             | Home Phone: 904/335-4914
Gainesville, Florida  32611       | Work Phone: 904/392-1450  FAX: 904/392-3380
-------------------------------------------------------------------------------


$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-010  25-Jun-1992
$!   On  4-MAR-1993 16:41:53.40   By user SYSOP 
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. FIDDEL.FOR;1
$!       2. FIDDEL_CLD.CLD;1
$!       3. MAKE.COM;1
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ x = P1 - f$parse(P1,,,"version")
$ y = f$search(x)
$ if y .eqs. "" then $ goto file_absent
$ x = f$integer(f$parse(P1,,,"version")-";")
$ y = f$integer(f$parse(y,,,"version")-";")
$ if x .gt. y then $ goto file_absent
$ if f$mode() .eqs. "INTERACTIVE" then $ goto file_interactive
$ if x .eq. y then e "-W-EXISTS, File ''P1' exists. Skipped."
$ if x .ne. y then e "-W-NEWERVERSION, of File ''P1' exists. Skipped."
$file_delete:
$ delete 'f'*
$ exit
$file_interactive:
$ if x .eq. y then e "-W-EXISTS, File ''P1' exists."
$ if x .ne. y then e "-W-NEWERVERSION, of File ''P1' exists."
$ read/error=file_delete/end=file_delete-
  /prompt="Create new version [y/n]: " -
  sys$command x
$ if .not. x then $ e "-W-SKIPPED, File ''P1' skipped."
$ if .not. x then $ goto file_delete
$ P1 = P1 - f$parse(P1,,,"version")
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
X`09program Enter
X
XC* Title:`09FIDDEL.FOR`09V0.1
XC* Author:`09Shawn A. Clifford
XC* Date:`0904-MAR-1993
XC* Purpose:`09Delete a file by its FID.
XC* Usage:`09FIDDEL `7Bfile_id`7D
XC*
XC*`09`09file_id   -  File identification in the form:
XC*`09`09`09number, sequence `5B, revision`5D
XC*
XC*`09`09number, sequence, revision  -  unsigned integers (word)
XC*
XC* Note:`09'FIDDEL' must be defined as a foreign command verb.
XC*`09`09eg.  FIDDEL:==$disk:`5Bdir`5DFIDDEL.EXE
XC*
XC* To Build:`09$ SET COM/OBJ FIDDEL_CLD
XC*`09`09$ FOR/NODEB/OPT/EXTEND FIDDEL
XC*`09`09$ LIN/NODEB/NOTRACE/CONTIG FIDDEL, FIDDEL_CLD
X
X
X`09implicit none
X
Xc`09include '($namdef)'
Xc`09include '($fabdef)'
Xc`09include '($fibdef)'
Xc`09include '($atrdef)'
Xc`09include '($iodef)'
X
Xc
Xc`09Converted all the $EQU statements in the $NAMDEF.MAR and $FABDEF.MAR
Xc`09macros, stored in the SYS$LIBRARY:STARLET.MLB macro library, into
Xc`09FORTRAN PARAMETER statements for symbol definitions.  Just using:
Xc`09`09include '($fabdef)'
Xc`09would not allow me to use the symbol names the way I needed.
Xc`09The important point is that the FAB$x_ (or NAM$x_) values are OFFSETS
Xc`09into the FAB/NAM blocks for the locations of the FAB/NAM fields.
Xc`09These offsets are BYTE offsets from the top of the block, therefore
Xc`09we need to divide by 2 or 4 when accessing WORD or LONGWORD cells.
Xc
Xc`09From $NAMDEF, $FABDEF, $ATRDEF, and $IODEF:
Xc
X`09PARAMETER`09NAM$C_BID`09=`092,
X`091`09`09NAM$C_BLN`09=`0996,
X`091`09`09NAM$C_MAXRSS`09=`09255,
X`091`09`09NAM$W_FID`09=`0936,
X`091`09`09NAM$W_FID_SEQ`09=`0938,
X`091`09`09NAM$W_FID_RVN`09=`0940,
X`091`09`09NAM$B_RSL`09=`093,
X`091`09`09NAM$B_ESL`09=`0911,
X`091`09`09NAM$B_BLN`09=`091,
X`091`09`09NAM$B_BID`09=`090,
X`091`09`09NAM$B_RSS`09=`092,
X`091`09`09NAM$B_ESS`09=`0910,
X`091`09`09NAM$L_RSA`09=`094,
X`091`09`09NAM$L_ESA`09=`0912
X
X`09PARAMETER `09FAB$C_BID`09=`093,
X`091`09`09FAB$C_BLN`09=`0980,
X`091`09`09FAB$M_NAM`09=`0916777216,
X`091`09`09FAB$M_OFP`09=`09536870912,
X`091`09`09FAB$B_FNS`09=`0952,
X`091`09`09FAB$B_DNS`09=`0933,
X`091`09`09FAB$B_BLN`09=`091,
X`091`09`09FAB$B_BID`09=`090,
X`091`09`09FAB$L_FOP`09=`094,
X`091`09`09FAB$L_NAM`09=`0940,
X`091`09`09FAB$L_FNA`09=`0944,
X`091`09`09FAB$L_DNA`09=`0948
X
X`09PARAMETER`09ATR$S_FILE_SPEC`09=`09512,
X`091`09`09ATR$C_FILE_SPEC`09=`0946
X
X`09PARAMETER`09IO$_ACCESS`09=`0950,
X`091`09`09IO$M_ACCESS`09=`0964,
X`091`09`09IO$_DEACCESS`09=`0952
X
X `09PARAMETER`09naml_siz = (NAM$C_BLN/4),
X`091`09`09namw_siz = (NAM$C_BLN/2),
X`091`09`09fabl_siz = (FAB$C_BLN/4),
X`091`09`09fabw_siz = (FAB$C_BLN/2)
X
Xc     Create an $QIOW argument descriptor
X`09structure /arg_descr/
X`09  union
X`09     MAP
X`09        integer*2 count
X`09        integer*2 not_used
X`09        integer*4 addr
X`09     END MAP
X`09     MAP
X                integer*4 eol`09/0/
X`09     END MAP
X`09  end union
X`09end structure
X`09record /arg_descr/ fib_descriptor
X
X
Xc     Create an attribute block
X`09structure /attribute_block/
X`09  union
X`09     MAP
X`09        integer*2 size
X`09        integer*2 type
X`09        integer*4 addr
X`09     END MAP
X`09     MAP
X                integer*4 eol`09/0/
X`09     END MAP
X`09  end union
X`09end structure
X`09record /attribute_block/ attrib
X
X
Xc     Create a short FIB block
X`09structure /fib_block/
X`09  union
X`09     MAP
X`09        integer*4 acctl
X`09     END MAP
X`09     MAP
X`09`09integer*2 acctl_overlay
X`09`09byte      acctl_overlay_2
X`09`09byte      wsize
X`09    ENDMAP
X`09  end union
X`09  union
X`09     MAP
X`09`09integer*2 fid
X`09     END MAP
X`09     MAP
X`09`09integer*2 fid_num
X`09     END MAP
X`09  end union
X`09`09integer*2 fid_seq
X`09`09integer*2 fid_rvn
X`09  union
X`09     MAP
X`09`09integer*2 did
X`09     END MAP
X`09     MAP
X`09`09integer*2 did_num
X`09     END MAP
X`09  end union
X`09`09integer*2 did_seq
X`09`09integer*2 did_rvn
X`09`09integer*4 wcc
X`09`09integer*2 nmctl
X`09end structure
X`09record /fib_block/ fib
X
Xc
Xc`09Define the access blocks.  Put the byte definitions after INTEGER*4,
Xc`09and before INTEGER*2 definitions to keep the blocks longword aligned.
Xc`09The access blocks are define for BYTE, WORD, and LONGWORD arrays
Xc`09so that we may access the different FAB/NAM cell locations according
Xc`09to the cell sizes.
Xc
X`09integer*4`09naml (0:naml_siz-1)
X`09integer*4`09fabl (0:fabl_siz-1)
X`09byte`09`09fabb (0:FAB$C_BLN-1)`09/FAB$C_BLN*0/
X`09byte`09`09namb (0:NAM$C_BLN-1)`09/NAM$C_BLN*0/
X`09integer*2`09nam  (0:namw_siz-1)
X`09integer*2`09fab  (0:fabw_siz-1)
X
X`09character*(NAM$C_MAXRSS)  inp_str, esa_str,`09! String space
X`091`09cmdline, res_str, dna_str`09`09/'FILE.ENTERED'/
X
X`09character*(ATR$S_FILE_SPEC)`09file
X`09character*(255) backlink
X`09character*37`09prompt/'Name of file entry (w/o wildcards):  '/
X`09character*5`09word_str`09! Read number data here, then convert.
X
X`09integer*2`09fid_num, fid_seq, fid_rvn`09! FileID words.
X`09integer*2`09chan, func
X
Xc`09Various string lengths.
X`09byte`09`09len, inp_str_len, res_str_len, esa_str_len,
X`091`09`09dna_str_len `09/12/
X
X`09integer*4`09stat, lib$get_input, sys$parse, lib$signal,
X`091`09`09sys$erase, ots$cvt_tu_l, sys$search, cli$present,
X`091`09`09cli$dcl_parse, cli$get_value, lib$get_foreign,
X`091`09`09sys$qiow, sys$assign, pos1, pos2
X
X`09external`09lib$get_input, sys$parse, lib$signal, sys$exit,
X`091`09`09sys$erase, ots$cvt_tu_l, sys$search, cli$present,
X`091`09`09cli$dcl_parse, cli$get_value, lib$get_foreign,
X`091`09`09fiddel_cld, sys$qiow, sys$assign, sys$dassgn
X
X
Xc
Xc`09Overlay common locations for easy access.
Xc
X`09equivalence`09(fabb,fab,fabl),`09! The FAB block.
X`091`09(namb,nam,naml),`09`09! The NAM block.
X`091`09(fid_num, nam(NAM$W_FID/2)),`09! The three ...
X`091`09(fid_seq, nam(NAM$W_FID_SEQ/2)),! ... words in
X`091`09(fid_rvn, nam(NAM$W_FID_RVN/2)),! ... the FID.
X`091`09(inp_str_len, fabb(FAB$B_FNS)),`09! File name length.
X`091`09(res_str_len, namb(NAM$B_RSL)),`09! Result str length.
X`091`09(dna_str_len, fabb(FAB$B_DNS)),`09! Default str length.
X`091`09(esa_str_len, namb(NAM$B_ESL))`09! Expanded str length.
X
X
XC-------------------------------------------------
X
Xc
Xc`09Setup the FIB and attribute block so that we may lookup the filename
Xc`09already assigned to a given FID.
Xc
X`09fib_descriptor.count = sizeof(fib)
X`09fib_descriptor.addr  = %loc(fib)
X
X`09attrib.size = ATR$S_FILE_SPEC
X`09attrib.type = ATR$C_FILE_SPEC
X`09attrib.addr = %loc(file)
X
Xc
Xc`09Initialize access blocks.
Xc`09Usually taken care of in MACRO by the $NAM and $FAB macros.
Xc
Xc`09First the NAM block...
Xc
X`09namb(NAM$B_BLN) = NAM$C_BLN`09! Define the size of the block.
X`09namb(NAM$B_BID) = NAM$C_BID`09! Tell RMS that it is a NAM block.
X`09namb(NAM$B_RSS) = NAM$C_MAXRSS`09! Tell how big result can be.
X`09namb(NAM$B_ESS) = NAM$C_MAXRSS`09! Tell how big expanded str may be.
X`09naml(NAM$L_RSA/4) = %loc(res_str)`09! Point to result string.
X`09naml(NAM$L_ESA/4) = %loc(esa_str)`09! Point to filespec to enter.
Xc
Xc`09... and now the FAB block.
Xc
X`09fabb(FAB$B_BLN) = FAB$C_BLN`09! Define size.
X`09fabb(FAB$B_BID) = FAB$C_BID`09! This is a FAB block.
Xc`09`09Let RMS know to use NAM block and DNA
X`09fabl(FAB$L_FOP/4) = FAB$M_NAM + FAB$M_OFP
X`09fabl(FAB$L_NAM/4) = %loc(nam)`09! Chain up the NAM block.
X`09fabl(FAB$L_FNA/4) = %loc(inp_str)`09! Point to input filespec.
X`09fabl(FAB$L_DNA/4) = %loc(dna_str)`09! Default file info.
X
Xc
Xc`09Use the CLI to get the filename and FID.
Xc`09The CLI will prompt for the FID if it is missing, and will return
Xc`09error messages on its own (hence sys$exit(1) below).
Xc
X`09call lib$get_foreign (cmdline,,len)
X`09stat=cli$dcl_parse('FIDDEL '//cmdline(:len), fiddel_cld,
X`091`09lib$get_input,,)
X`09if (iand(stat, '00000001'x).ne.1) call sys$exit(%val(1))
X
Xc
Xc`09Parse the input so that we may get the expanded string length.
Xc
X`09stat = sys$parse(fab,,)
X`09if (IAND(stat,'00000001'x).ne.1) call sys$exit(%val(stat))
X
Xc
Xc`09Get the FID.  You don't usually use the relative volume number.
Xc`09Note:  fid_xxx map directly into their NAM fields.  We set these
Xc`09AFTER calling sys$parse because sys$parse zeroes these fields out.
Xc`09Values are read into a character buffer, then converted to
Xc`09unsigned words, ignoring tabs and blanks.
Xc
Xc`09`09File number
Xc
X`09if (cli$get_value('IDENTIFIER', word_str, len))
X`091   call ots$cvt_tu_l(word_str, fid_num, %val(2), %val('11'x))
Xc`09`09File sequence
X`09if (cli$get_value('IDENTIFIER', word_str, len))
X`091`09call ots$cvt_tu_l(word_str, fid_seq, %val(2), %val('11'x))
Xc`09`09File revision
X`09if (cli$get_value('IDENTIFIER', word_str, len))
X`091`09call ots$cvt_tu_l(word_str, fid_rvn, %val(2), %val('11'x))
X
Xc
Xc`09Get the backlink on the file.
Xc
X`09fib.fid_num = fid_num
X`09fib.fid_seq = fid_seq
X`09fib.fid_rvn = fid_rvn
X
X`09stat = sys$assign('sys$disk', %ref(chan),,)
X`09if (IAND(stat,'00000001'x).ne.1) call sys$exit(%val(stat))
X
X`09func = IO$_ACCESS + IO$M_ACCESS
X`09stat = sys$qiow(,%val(chan),%val(func),,,,fib_descriptor,,,,
X`091`09%ref(attrib),)
X
X`09func = IO$_DEACCESS
X`09stat = sys$qiow(,%val(chan),%val(func),,,,fib_descriptor,,,,
X`091`09%ref(attrib),)
X`09if (IAND(stat,'00000001'x).ne.1) call sys$exit(%val(stat))
X
X        call sys$dassgn(%val(chan))
X
Xc
Xc`09   File spec is returned as a counted string w/ null padding.  Skip
Xc`09   over the count word, and cut out the backlink and the file name.
Xc
X`09pos1 = index(file, '`5B')
X`09pos2 = index(file, '`5D')
X`09backlink = file(pos1:pos2)
X`09pos1 = pos2+1
X`09pos2 = index(file, ';') -1
X`09file = file(pos1:pos2)
X`09pos2 = pos2-pos1+1
X`09pos1 = index(backlink, '`5D')
X
X`09print *
X`09print *, 'Backlink directory:   ', backlink(:pos1)
X`09print *, 'Deleted file name :   ', file(:pos2)
X
Xc
Xc`09Delete the file.
Xc
X`09stat = sys$erase(fab,,)
X`09if (IAND(stat,'00000001'x).ne.1) call sys$exit(%val(stat))
X
X`09end
$ CALL UNPACK FIDDEL.FOR;1 1632665873
$ create 'f'
X!**************************************ENTER********************************
V***
X! Title:`09FIDDEL_CLD.CLD
X! Author:`09Shawn A. Clifford
X! Date:`09`0904-FEB-1993
X! Purpose:`09Module to be compiled (via SET COM/OBJ ENTER_CLD) in order
X!`09`09to define the paramaters for FIDDEL.  Define a foreign
X!`09`09command symbol for FIDDEL.EXE in order to pass parameters.
X!
X! ID:`09`09File id in the form:    number, number`5B, number`5D
X!
Xmodule FIDDEL_CLD
Xdefine verb FIDDEL
X   parameter p1, label=IDENTIFIER, prompt="ID"
X      value (required,list,type=$number)
$ CALL UNPACK FIDDEL_CLD.CLD;1 645342841
$ create 'f'
X$! @MAKE to build FIDDEL.EXE
X$ set on
X$ on error then goto end
X$ on warning then continue
X$ ver = f$verify(1)
X$ set com/obj fiddel_cld
X$ fortran/nodeb/opt/extend fiddel
X$ link/nodeb/notrace/contig fiddel, fiddel_cld
X$ end:
X$   exit ($status + 0*f$verify(ver))
$ CALL UNPACK MAKE.COM;1 2120603110
$ v=f$verify(v)
$ EXIT

