Routine to get information about current image

1 view
Skip to first unread message

Lawrence Bleau

unread,
Apr 4, 1995, 3:00:00 AM4/4/95
to
Submitted-by: bl...@UMDSP.UMD.EDU (Lawrence Bleau)
Posting-number: Volume 7, Issue 48
Archive-name: get_image_info/part01

FUNCTIONAL DESCRIPTION:

This [Fortran] subroutine obtains and returns to the caller the name of
the current program, the full file specification of the image file being
run, the date and time the current program was linked, and the version (if
any) of the current program.

Larry Bleau
University of Maryland
bl...@umdsp.umd.edu
301-405-6223

$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_UNPACK_VERIFY"))'
$!
$! This archive created:
$! Name : GET_IMAGE_INFO
$! By : berr...@MVB.SAIC.COM
$! Date : 3-APR-1995 18:18:25.83
$! Using: VMS_SHARE 8.5-1, (C) 1993 Andy Harper, Kings College London UK
$!
$! Credit is due to these people for their original ideas:
$! James Gray, Michael Bednarek
$!
$! To unpack this archive:
$! Minimum of VMS 4.4 (VAX) / OpenVMS 1.0 (Alpha) is required.
$! Remove the headers of the first part, up to `cut here' line.
$! Execute file as a command procedure.
$!
$! The following file(s) will be created after unpacking:
$! 1. GET_IMAGE_INFO.FOR;1
$!
$ set="set"
$ set symbol/scope=(nolocal,noglobal)
$ f="SYS$SCRATCH:."+f$getjpi("","PID")+";"
$ if f$trnlnm("SHARE_UNPACK") .nes. "" then $ -
f=f$parse("SHARE_UNPACK_TEMP",f)
$ e="write sys$error ""%UNPACK"", "
$ w="write sys$output ""%UNPACK"", "
$ if .not. f$trnlnm("SHARE_UNPACK_LOG") then $ w = "!"
$ if f$getsyi("CPU") .gt. 127 then $ goto start
$ 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=file,P2=chksum,P3=attrib,P4=size,P5=fileno,P6=filetotal
$ 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:
$ x=f$search(P1)
$ if x .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped"
$ delete 'f'*
$ exit
$file_absent:
$ w "-I-UNPACK, Unpacking ", P5, " of ", P6, " - ", P1, " - ", P4, " Blocks"
$ n=P1
$ if P3 .nes. "" then $ n=f
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT/NOJOURNAL 'f'/OUT='n'
PROCEDURE GetHex(s,p)LOCAL x1,x2;x1:=INDEX(t,SUBSTR(s,p,1))-1;x2:=INDEX(t,
SUBSTR(s,p+1,1))-1;RETURN 16*x1+x2;ENDPROCEDURE;PROCEDURE SkipPartsep LOCAL m;
LOOP m:=MARK(NONE);EXITIF m=END_OF(CURRENT_BUFFER);DELETE(m);EXITIF INDEX(
ERASE_LINE,"-+-+-+-+-+-+-+-+")=1;ENDLOOP;ENDPROCEDURE;
PROCEDURE ProcessLine LOCAL c,s,l,b,n,p;s := ERASE_LINE;c := SUBSTR(s,1,1);s :=
s-c;IF c = "X" THEN SPLIT_LINE; ENDIF;MOVE_HORIZONTAL(-1);l := LENGTH(s);p :=
1;LOOP EXITIF p > l;c := SUBSTR(s,p,1);p := p+1;CASE c FROM ' ' TO '`' ['`']
: COPY_TEXT(ASCII(GetHex(s,p))); p:=p+2;[' ']: p:=p+1;[INRANGE,OUTRANGE]
: COPY_TEXT(c);ENDCASE;ENDLOOP;ENDPROCEDURE;PROCEDURE Decode(b)LOCAL m;
POSITION(BEGINNING_OF(b));LOOP m:=MARK(NONE);EXITIF m=END_OF(b);DELETE(m);
IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+-")=1 THEN SkipPartSep;ELSE ProcessLine;
MOVE_HORIZONTAL(1);ENDIF;ENDLOOP;ENDPROCEDURE;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);t:="0123456789ABCDEF";f:=GET_INFO(
COMMAND_LINE,"file_name");o:=CREATE_BUFFER(f,f);Decode(o);WRITE_FILE(o,
GET_INFO(COMMAND_LINE,"output_file"));QUIT;
$ if p3 .eqs. "" then $ goto dl
$ open/write fdl &f
$ write fdl "RECORD"
$ write fdl P3
$ close fdl
$ w "-I-CONVRFM, Converting record format to ", P3
$ convert/fdl='f' 'f'-1 'f'
$ fa=f$getdvi(f$parse(f),"ALLDEVNAM")
$ Pa=f$getdvi(f$parse(P1),"ALLDEVNAM")
$ if fa .eqs. Pa then $ rename &f 'f$parse(P1)'
$ if fa .nes. Pa then $ copy &f 'f$parse(P1)'
$dl: delete 'f'*
$ checksum 'P1'
$ if checksum$checksum .nes. P2 then $ -
e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ exit
$ endsubroutine
$start:
$!
$ create 'f'
X`09SUBROUTINE`20get_image_info`20(what_to_get,`20result_string,`20result_len)
V
XC+
XC`20
XC`20FUNCTIONAL`20DESCRIPTION:`09
XC`20
XC`20`20`20`20This`20subroutine`20obtains`20and`20returns`20to`20the`20caller
V`20the`20name`20of`20the`20current
XC`20`20`20`20program,`20the`20full`20file`20specification`20of`20the`20image
V`20file`20being`20run,`20the`20date
XC`20`20`20`20and`20time`20the`20current`20program`20was`20linked,`20and`20the
V`20version`20(if`20any)`20of`20the
XC`20`20`20`20current`20program.
XC
XC`20FORMAL`20PARAMETERS:
XC`20`20
XC`20`20`20`20`20what_to_get:
XC`09`20`20`20A`20CHARACTER`20variable`20or`20constant`20specifying`20the`20ite
Vm`20of`20information
XC`09`20`20`20you`20want`20to`20get.`20`20Allowable`20values`20are`20given`20in
V`20the`20table`20below;
XC`09`20`20`20anything`20else`20will`20return`20an`20empty`20string`20(blank`20
Vwith`20length`20of`200.
XC
XC`09`20`20`20`20Keyword
XC`20`20`20`20`20`20`20`20`20`20`20Value`09Item`20returned
XC`09`20`20`20`20'PROG'`09name`20of`20program`20being`20run;`20is`20name`20only
V,`20obtained
XC`09`09`09from`20image`20file`20header,`20does`20not`20include`20device,
XC`09`09`09directory,`20or`20file`20type;`20may`20be`20different`20from`20image
V
XC`09`09`09file`20name`20if`20file`20was`20RENAMEd`20or`20COPYied
XC`09`20`20`20`20'FILE'`09full`20file`20specification`20of`20image`20file`20for
V`20current
XC`09`09`09program
XC`09`20`20`20`20'LINK'`09date/time`20when`20this`20image`20was`20linked
XC`09`20`20`20`20'VERS'`09developer-supplied`20program`20version`20identificati
Von
XC
XC`20`20`20`20`20result_string:
XC`09`20`20`20A`20CHARACTER`20variable`20of`20appropriate`20length`20which`20wi
Vll`20receive`20the
XC`09`20`20`20the`20item`20requested.`20`20If`20the`20information`20item`20is
V`20too`20long`20for`20this
XC`09`20`20`20argument`20the`20information`20item`20will`20be`20truncated`20wit
Vh`20no`20warning`20to
XC`09`20`20`20the`20caller.`20`20If`20it`20is`20shorter`20the`20argument`20will
V`20be`20blank`20filled.
XC
XC`20`20`20`20`20result_len:
XC`09`20`20`20An`20INTEGER*4`20variable`20which`20upon`20return`20will`20contai
Vn`20the`20number`20of
XC`09`20`20`20characters`20stored`20into`20RESULT_STRING.
XC
XC`20DESIGN:
XC`20`20
XC`20`20`20`20`20Use`20LIB$GETJPI`20to`20get`20the`20filename`20of`20the`20curr
Vent`20program.`20`20Read`20its
XC`20`20`20`20`20header`20block`20(first`20block`20in`20file)`20and`20decode`20
Vthe`20rest`20from`20there.`20`20The
XC`20`20`20`20`20program`20name`20stored`20in`20the`20header`20may`20be`20diffe
Vrent`20from`20the`20filename`20part
XC`20`20`20`20`20of`20the`20image`20name,`20which`20is`20why`20they`20are`20ret
Vurned`20separately.`20`20Take`20care
XC`20`20`20`20`20of`20name`20truncation.`20`20Strings`20in`20the`20header`20are
V`20in`20counted`20string`20format
XC`20`20`20`20`20(initial`20byte`20gives`20length).
XC
XC`20`20`20`20`20This`20code`20assumes`20the`20entire`20identification`20area
V`20is`20contained`20within`20the
XC`20`20`20`20`20first`20header`20block.
XC
XC`20`20`20`20`20N.B.:`20The`20correct`20offsets`20for`20the`20various`20parts
V`20of`20the`20header`20are`20given
XC`20`20`20`20`20in`20the`20macros`20$IHDDEF`20and`20IHIDEF,`20which`20are`20de
Vfined`20in`20LIB.MLB.`20`20Since
XC`20`20`20`20`20there`20is`20no`20Fortran`20version`20of`20these`20files`20the
V`20offsets`20used`20are`20listed
XC`20`20`20`20`20below`20and`20are`20symbolicaly`20defined`20within`20this`20fi
Vle.`20`20They`20are`20zero-origin
XC`20`20`20`20`20byte`20offsets,`20which`20is`20why`201`20is`20added`20when`20r
Veferencing`20them`20through`20the
XC`20`20`20`20`20equivalenced`20character`20variable`20cbuf.`20`20These`20offse
Vts`20may`20change`20in`20a
XC`20`20`20`20`20later`20version`20of`20VMS,`20at`20which`20time`20this`20code
V`20may`20stop`20working.`20`20The
XC`20`20`20`20`20values`20will`20then`20have`20to`20be`20updated`20from`20the
V`20new`20version`20of`20$IHDDEF`20and
XC`20`20`20`20`20$IHIDEF.
XC
XC`20`20`20`20`20Symbolic`20Name`20`20`20`20`20`20Value`20`20`20`20`20Offset`20
Vinto:`20`20`20`20`20Description
XC`20`20`20`20`20EIHD$L_IMGIDOFF`09`20`20`2024`20`20`20`20`20`20header`20block
V`200`20`20`20location`20of`20ident`20area
XC`20`20`20`20`20EIHI$Q_LINKTIME`20`20`20`20`20`20`208`20`20`20`20`20`20ident
V`20area`20`20`20`20`20`20`20link`20date`20and`20time
XC`20`20`20`20`20EIHI$T_IMGNAM`20`20`20`20`20`20`20`2016`20`20`20`20`20`20ident
V`20area`20`20`20`20`20`20`20program`20name
XC`20`20`20`20`20EIHI$T_IMGID`20`20`20`20`20`20`20`20`2056`20`20`20`20`20`20ide
Vnt`20area`20`20`20`20`20`20`20program`20version
XC
XC
XC`20NOTE:
XC`20`20
XC`20`20`20`20`20This`20routine`20has`20been`20developed`20and`20tested`20only
V`20on`20OpenVMS`206.1`20AXP`20(an
XC`20`20`20`20`20Alpha`20system).`20`20It`20has`20not`20been`20tested`20on`20ea
Vrlier`20versions`20of`20VMS`20or`20on
XC`20`20`20`20`20OpenVMS`20VAX-format`20images.`20`20If`20the`20image`20formats
V`20differ`20it`20will`20likely
XC`20`20`20`20`20fail.`20`20In`20fact,`20it`20will`20probably`20NOT`20work`20on
V`20OpenVMS`20VAX`20images.
XC`20`20
XC`20
XC`20This`20version:`20`20`20`208-MAR-1995
XC`20
XC`20Created:`20
XC`20
XC`09`207-MAR-1995`20`20`20`20Larry`20Bleau
XC`09`09`20`20`20`20`20`20`20University`20of`20Maryland
XC`09`09`20`20`20`20`20`20`20Physics`20Dept.,`20Space`20Physics`20Group
XC`09`09`20`20`20`20`20`20`20b...@umdsp.umd.edu
XC`20
XC`20Revised:
XC`20
XC`09`20Date`20`20`20`20`20`7C`20Name`20`20`7C`20Description
XC`20----------------+-------+-------------------------------------------------
V----
XC`20`208-MAR-1995`20`20`20`20`20`7C`20`20LRB`20`20`7C`20changed`20to`20use`20s
Vymbolic`20offsets`20instead`20of
XC`20`20`09`09`09`20`20`20`20hard-coding`20them
XC`20
XC-
X`09IMPLICIT`20NONE
X`09CHARACTER*(*)`20what_to_get,result_string
X`09INTEGER*4`20result_len
XC
X`09INCLUDE`20'($JPIDEF)/NOLIST'
X
X`09INTEGER`20EIHD$L_IMGIDOFF`09
X`09PARAMETER`20(EIHD$L_IMGIDOFF`09=`2024)`09!`20location`20of`20ident`20area
X`09INTEGER`20EIHI$Q_LINKTIME
X`09PARAMETER`20(EIHI$Q_LINKTIME`09=`208)`20`09!`20link`20date`20and`20time
X`09INTEGER`20EIHI$T_IMGNAM
X`09PARAMETER`20(EIHI$T_IMGNAM`09=`2016)`09!`20program`20name
X`09INTEGER`20EIHI$T_IMGID
X`09PARAMETER`20(EIHI$T_IMGID`09`09=`2056)`09!`20program`20version
X
X`09INTEGER*4`20status,unit,pos,nch,image_len,ident_offset
X`09INTEGER*4`20LIB$GET_LUN,LIB$FREE_LUN,LIB$SYS_ASCTIM,LIB$GETJPI
X`09INTEGER*2`20reslen
X`09INTEGER*4`20buf(0:127)
X`09BYTE`20bbuf(0:511)
X`09CHARACTER`20cbuf*512,time_str*23
X`09EQUIVALENCE`20(buf,bbuf,cbuf)
X`09CHARACTER*120`20image_name
X`09LOGICAL`20first_time/.TRUE./
X`09SAVE`20image_name,image_len,buf,first_time,ident_offset
XC
XC`20Initialize`20arguments`20to`20empty`20values`20in`20case`20we`20get`20an
V`20error.
XC
X`09result_string`20=`20'`20'
X`09result_len`20=`200
XC
XC`20First`20get`20the`20full`20file`20specification`20of`20the`20image`20so`20
Vwe`20can`20open`20it`20and`20read
XC`20its`20header.`20`20If`20we`20get`20an`20error`20just`20return`20with`20emp
Vty`20strings.
XC`20If`20successful`20remove`20any`20'`5D`5B'`20from`20string`20and`20store`20
Vit`20in`20caller's`20argument.
XC`20We`20needn't`20do`20this`20except`20on`20first`20call.
XC`20
X`09IF`20(first_time)`20THEN
X`09`20`20`20`20status`20=`20LIB$GETJPI`20(JPI$_IMAGNAME,,,,`20image_name,`20re
Vslen)
X`09`20`20`20`20IF`20(status`20.ne.`201)`20RETURN
Xc`09`20`20`20`20type`20*,'#`20chars`20in`20image`20name`20=`20',reslen
Xc`09`20`20`20`20type`20*,'image`20name`20=',image_name(1:reslen)
X`09`20`20`20`20pos`20=`20INDEX`20(image_name(1:reslen),`20'`5D`5B')
X`09`20`20`20`20IF`20(pos`20.ne.`200)`20THEN
X`09`20`20`20`20`20`20`20`20image_name`20=`20image_name(1:pos-1)`20//`20image_n
Vame(pos+2:)
X`09`20`20`20`20`20`20`20`20reslen`20=`20reslen`20-`202
X`09`20`20`20`20END`20IF
X`09`20`20`20`20image_len`20=`20reslen
XC
XC`20Obtain`20free`20unit`20number`20with`20which`20to`20do`20i/o`20to`20image
V`20file.
XC
X`09`20`20`20`20status`20=`20LIB$GET_LUN`20(unit)
X`09`20`20`20`20IF`20(status`20.ne.`201)`20RETURN
XC
XC`20Now`20open`20the`20image`20file,`20read`20the`20first`20block,`20and`20clo
Vse`20it
XC
X`09`20`20`20`20OPEN(UNIT=unit,`20NAME=image_name(1:reslen),`20STATUS='OLD',`20
V
X`20`20`20`20`20*`09`20`20`20`20`20`20`20`20`20ACCESS='DIRECT',`20FORM='UNFORMA
VTTED',`20RECL=128,`20READONLY,
X`20`20`20`20`20*`09`20`20`20`20`20`20`20`20`20IOSTAT=STATUS,`20ERR=910)
X`09`20`20`20`20READ(unit'1,IOSTAT=status,ERR=900)`20buf
X`09`20`20`20`20CLOSE(unit)
XC
XC`20Release`20unit,`20fetch`20offset`20to`20identification`20area,`20and`20cle
Var`20first-time`20flag
XC`20Since`20offset`20is`20byte`20offset`20and`20buf`20is`20longword`20(integer
V*4)`20divide`20by`204`20to
XC`20get`20index`20into`20buf
XC
X`09`20`20`20`20status`20=`20LIB$FREE_LUN`20(unit)
X`09`20`20`20`20IF`20(status`20.ne.`201)`20RETURN
X`09`20`20`20`20ident_offset`20=`20buf(EIHD$L_IMGIDOFF/4)
X`09`20`20`20`20first_time`20=`20.FALSE.
X`09END`20IF
XC
XC`20At`20this`20point`20we`20have`20a`20valid`20image`20file`20specification
V`20in`20image_name`20and`20a
XC`20valid`20image`20header`20in`20buf
XC
XC`20If`20caller`20wants`20image`20file`20name`20pass`20contents`20of`20image_n
Vame`20back`20to`20caller
XC
X`09IF`20(what_to_get`20.eq.`20'FILE')`20THEN
X`09`20`20`20`20nch`20=`20MIN(image_len,`20LEN(result_string))
X`09`20`20`20`20result_string`20=`20image_name(1:nch)
X`09`20`20`20`20result_len`20=`20nch
X`09END`20IF
XC
XC`20If`20caller`20wants`20program`20name`20extract`20it`20from`20header`20and
V`20give`20it`20to`20caller
XC
X`09IF`20(what_to_get`20.eq.`20'PROG')`20THEN
X`09`20`20`20`20pos`20=`20ident_offset`20+`20EIHI$T_IMGNAM
X`09`20`20`20`20nch`20=`20bbuf(pos)
X`09`20`20`20`20nch`20=`20MIN(nch,`20LEN(result_string))
X`09`20`20`20`20IF`20(nch`20.gt.`200)`20THEN
X`09`20`20`20`20`20`20`20`20result_string`20=`20cbuf(pos+2:pos+nch+1)
X`09`20`20`20`20`20`20`20`20result_len`20=`20nch
X`09`20`20`20`20END`20IF
X`09END`20IF
XC
XC`20If`20caller`20wants`20version`20extract`20it`20from`20header`20and`20give
V`20it`20to`20caller
XC
X`09IF`20(what_to_get`20.eq.`20'VERS')`20THEN
X`09`20`20`20`20pos`20=`20ident_offset`20+`20EIHI$T_IMGID
X`09`20`20`20`20nch`20=`20bbuf(pos)
X`09`20`20`20`20nch`20=`20MIN(nch,`20LEN(result_string))
X`09`20`20`20`20IF`20(nch`20.gt.`200)`20THEN
X`09`20`20`20`20`20`20`20`20result_string`20=`20cbuf(pos+2:pos+nch+1)
X`09`20`20`20`20`20`20`20`20result_len`20=`20nch
X`09`20`20`20`20END`20IF
X`09END`20IF
XC
XC`20If`20caller`20wants`20link`20date/time`20extract`20it`20from`20header`20in
V`20quadword`20format,
XC`20convert`20it`20to`20ascii,`20and`20give`20it`20to`20caller
XC
X`09IF`20(what_to_get`20.eq.`20'LINK')`20THEN
X`09`20`20`20`20pos`20=`20(ident_offset`20+`20EIHI$Q_LINKTIME)`20/`204
X`09`20`20`20`20status`20=`20LIB$SYS_ASCTIM`20(reslen,`20time_str,`20buf(pos),
V`20)
X`09`20`20`20`20IF`20(status`20.eq.`201`20.and.`20reslen`20.gt.`200)`20THEN
X`09`20`20`20`20`20`20`20`20nch`20=`20MIN(reslen,`20LEN(result_string))
X`09`20`20`20`20`20`20`20`20result_string`20=`20time_str(1:nch)
X`09`20`20`20`20`20`20`20`20result_len`20=`20nch
X`09`20`20`20`20END`20IF
X`09END`20IF
XC
XC`20All`20done
XC
X`09RETURN
XC
XC`20Error`20handling`20code
XC
X900`09CLOSE(unit)
X910`09RETURN
X`09END
$ call unpack GET_IMAGE_INFO.FOR;1 875600948 "" 16 1 1
$ v=f$verify(v)
$ exit

Reply all
Reply to author
Forward
0 new messages