9) Bad Math $ v = f$verify() $ a = 1 $ b = 1 $ c = a + b $ c = c + 1 ! 'f$verify(0)' $ if v then set verify $ show symbol c $ exit ! Skip Morris Good Book> "Writing Real Programs in DCL" by Paul C Anagnostopoulos
8) one liners $ open f temp.'f$getjpi("","PID") /write ! unique temp file for process ! see adv. dcl hack for others $ delete /log temp.'f$getjpi("","PID")'; ! and delete it ! open temp file to a queue $ open p 'f$getqui("display_queue","device_name","lp26_printer") /write ! (kag) $ if f$trnlnm("P") .nes. "" then close p ! file open? close it (CJL) ! leap year? (KGB) $ leapyear = 3 - f$cvti("28-feb-'year'+1-",,"month") $ old_priv = f$setprv("SYSNAM") ! 'f$verify(0) hide it :-) $ exit 1+0*f$verify(old_verify)*f$setprv(old_priv) ! verify on after exit $ set default 'f$elem(0,"]",f$envi("PROCEDURE"))'] ! move to com's dir
7) Pass back a symbol, specified by caller $ ! caller does $ @swing Your "partner " "round " "and " "round " $ sho sym your ! display the returned symbol $ exit $ ! swing.com $ 'p1 == p2 + p3 + p4 + p5 + p6 + p7 $ exit
6) More one liners $ create nl: ! turn your xterm in to a paste board $ type nl:/page ! clear screen ! remote node reachable? (DECnet) $ open lnk rmtnod::"26="/read/write/error=notreachable ! use evl $ run/det sys$system:loginout /input=xxx.com /out=xxx.log /proc="The UnBatch" $ PURGEX ! to get default behavior (doesn't match purg*e) (idx) $ del/log [...]*.*;*,*.*.*,*.*.*,*.*.*,*.*.*,*.*.*,*.*.*,*.*.*,*.*.* ! kari Nousiainen
5) Ways to count records $ copy some.file nl:/log or for ISAM files $ convert some_isam.file NL:/stat/fdl=sys$input FILE ORG SEQ $! f$file_attr("some.file","org") ! will tell whether it's an isam (idx) or for both $ search some.file /out=nl: /stat ! from the crowd
4) WhatIs_SysOut $ goto devclass_'f$getdvi("sys$output","devclass") ! assume disk or term $ exit ! tape? $devclass_66: ! terminal $ logfile == f$log( "sys$output") $ exit $devclass_1: ! disk $ goto 'f$mode() $ exit ! what? $BATCH: $ deflogfile = f$getqui("display_job","log_specification",,"this_job") $ cmdfile = f$getqui("display_file", "file_specification",,"this_job") $ sys_login = f$trnlnm("sys$login")+".log;" $ logfile = f$parse( deflogfile, sys_login, cmdfile) - "][" - "><" ! <* $ exit $NETWORK: ! open lnk xyz::"task=whatis_sysout"/read/write $ open lnk sys$net /read/write ! for testing $ pid = f$getjpi("","PID") $ sho dev sys$output/file /nosyst /out=all_open_files.'pid' ! slow $ sear all_open_files.'pid' 'pid'/out=open_files.'pid' ! net t-o $ close lnk $ dele/nolog all_open_files.'pid';* $ open of open_files.'pid'/read $nlp: $ read of pn_pid_fs $ pn_pid_fs = f$edit( pn_pid_fs, "compress") $ if f$loca( "NETSERVER.LOG", pn_pid_fs) .eqs. f$len( pn_pid_fs) then goto nlp $finishUp: $ close of $ dele open_files.'pid';* /nolog $ logfile = f$elem( 2, " ", pn_pid_fs) $ sho sym logfile $ eoj ! exit $OTHER: $ pid = f$getjpi("","PID") $ sho dev sys$output/file /nosyst /out=all_open_files.'pid' ! slow $ sear all_open_files.'pid' 'pid'/out=open_files.'pid' $ dele all_open_files.'pid';* $ open of open_files.'pid'/read $ read of pn_pid_fs ! seems to be the 1st one $ pn_pid_fs = f$edit( pn_pid_fs, "compress") $ goto finishUp $Interactive: $ sho log sys$output $ exit
3) Output without cr-lf sdt.xxx $ wr0crlf:=call wr0crlf $ i=0 $ loop: $ wr0crlf "." $ wait 00:00:01 $ i=i+1 $ if i.lt.40 then goto loop $ endloop: $ exit $! $ wr0crlf: subroutine $ read/time=0/error=next sys$command/prompt="''p1'" garb $ next: $ return OK ? Arne Arne Vajhøj local DECNET: KO::ARNE Computer Department PSI: PSI%238310013040::ARNE Business School of Southern Denmark Internet: ARNE@KO.HHS.DK $! or you can play darts with it. $ p = " >>==-" $ p[0,32]=%x08080808 ! ^H $ p[32,8]=8 $lp: $ read /time=0/error=next sys$command/prom="''p'" nil $next: $ wait 00:00:00.01 $ goto lp
2) DCL does window $ ! set_title_icon.com p1-title, p2-icon $ osc[0,8] = 157 $ st[0,8] = 156 $ if f$len(p2) .eq. 0 then p2 = p1 $ write sys$output osc,"2L;''p2'",st ! set icon $ write sys$output osc,"21;''p1'",st ! set title bar $ exit ! Skip Morris ! I have a symbol HEY defined which changes the title bar & icon and ! then does a SET HOST, and sets it back on logout. ! YO does the same thing for telnet
1) Sending anonymous mail with dcl . dclmail.com drop $ ! Hacking MAIL from DCL, p1 user, p2 node( no ::) $ nil[0,8] = 0 ! set up nil $ if f$len(p2) .eq. 0 then p2 = "0" ! must be local $ open link 'p2'::"27="/read/write $ write link "Still here" ! placed in From: $ write link p1 ! actual username sending to $ read link mstatus $ if .not. f$cvui(0,32,mstatus) then goto eh ! addressee error?, no $ write link nil ! end of addressee list $ write link "Lame Duck (who else)" ! placed in To: $ write link "You Rang?" ! placed in Subj: $ write link "Can you guess who this is from!" ! placed in message $ write link "p.s. you get 2 tries." $ write link nil ! end of message $ read link mstatus $ if .not. f$cvui(0,32,mstatus) then goto eh ! things ok?, no $ close link $ exit $eh: ! error handler $ set message sys$message:cliutlmsg $ em = f$message(f$cvui(0,32,mstatus)) $ write sys$Output f$fao(em,p1,p2) $ close link $ exit ! swiped from somewhere Of course it's even easier with SMTP
11) Psuedo pipes: show system | search p1 $ ! piper - simulate pipes, p1-p8 or use " " if > 8 parameters $ px = p1+" "+p2+" "+p3+" "+p4+" "+p5+" "+p6+" "+p7+" "+p8 $ sho sym px $ n = 0 $ pid = f$getjpi("","pid") $lp: $ p = f$elem(n,"|",px) $ pn = f$elem(n+1,"|",px) $ if p .eqs. "|" then goto clean_up $ if n .gt. 0 - then defi /user sys$Input sys$scratch:pipe'f$str(n-1)'tmp.'pid' $ if pn .nes. "|" - then defi /user sys$output sys$scratch:pipe'n'tmp.'pid' $ 'p' $ n = n+1 $ goto lp $clean_up: $ delete sys$scratch:pipe*tmp.'pid'; $ exit $ piper :== @sys$common:[usrcom]piper $ piper show devi/file/nosyst sys$sysdevice:|search sys$Input job_con $ ! show system | search p1 sss $ pipe = "sys$login:pipe."+f$getjpi("","pid") $ show system/out='pipe $ search 'pipe 'p1' $ delete 'pipe'; /nolog $ exit $ ! show user | search p1 sus $ pipe = "sys$login:pipe."+f$getjpi("","pid") $ show user/full /out='pipe $ search 'pipe 'p1' $ delete 'pipe'; /nolog $ exit $ ! show queue/all/full | search p1 sqs $ pipe = "sys$login:pipe."+f$getjpi("","pid") $ show queue/all/full /out='pipe $ search 'pipe 'p1' $ delete 'pipe'; /nolog $ exit
12) example of batch restart options nov93 restrt.com $ show sym $restart ! this becomes TRUE on restart $ if f$type(batch$restart) .nes. "" ! this is empty the first time $ then show sym batch$restart $ goto 'batch$restart $ endif $phase0: $ set proc/name="Restart 0" $ wait 00:01:00 $phase1: $ set restart = phase1 ! this will set batch$restart $ set proc/name="Restart 1" $ wait 00:01:00 $phase2: $ set restart = phase2 ! this will set batch$restart $ set proc/name="Restart 2" $ wait 00:01:00 $ exit To use this $ submit /noprint restrt.com /log_f=[] /que=myq /RESTART to restart it $ STOP/QUEU /ENTR=### /REQUEUE myq
13) Lets do the Time Warp again. (Spring forward/Fall back) tw.com $ ! Spring forward, Fall back, assuming start time 1:59 am $ year = f$cvtime(,,"year") ! get current year $ mo = f$cvtime(,,"month") ! month $ ms = "SuMoTuWeThFrSa" ! nifty conversion table $ goto 'mo ! dcl at its best, goto month $ exit 2 ! hmmm, better quit $ $04: !April $ time_change = "+1:00:00" ! spring forward $ nxtmonth = "-Oct-" ! calculate next submit time $ nxtyear = year ! year stays the same $ wkd = f$cvti( "31-Oct-"+year,, "weekday") ! what is the weekday of 31-Oct $ nxtda = 31 - f$loca(f$extr( 0,2, wkd),ms)/2 ! index table, back up to sunday $ goto wrap_up $ $10: ! October $ time_change = "-1:00:00" ! fall back $ nxtmonth = "-Apr-" ! calculate next submit time $ nxtyear = f$str(year + 1) ! next year and make type=string $ wkd = f$cvti( "7-Apr-"+nxtyear,, "weekday") ! what is the weekday of 7-Apr $ nxtda = 7 - f$loca(f$extr(0,2, wkd), ms)/2 ! index table, back up to sunday $ $wrap_up: $ set proc/priv=(oper,log_io) ! altpri to if you want to raise prio. $ s = f$cvti(,,"second") ! now wait till 2 am $ if s .ne. 0 then wait 00:00:'f$str(60-s) $ set time = "''time_change'" !/cluster $ reply/all/bell "Time Warp ''f$time()' " ! notify others, log on console $ nxtime := 'nxtda''nxtmonth''nxtyear':1:59:00 $ subm /aft='nxtime' sys$manager:timewarp/noprint /queue=sys_stuff $ exit
14) Resolving Message Numbers. rmn.com $! resolve message number if exit doesn't work $! p1 is a message number to resolve $ ifs := sys$message:*.exe; ! starting point of file search $ set noon ! ignore file header errors $lp: $ fs = f$search( ifs) ! find a message file $ if f$len( fs) .eq. 0 then goto done $ set message 'fs ! select the message file $ fsn = f$parse( fs,,,"NAME","SYNTAX_ONLY") $ write sys$output "trying: ''fsn'" ! show what we'll try $ em = f$message(p1) ! any thing besides noname- ? $ if f$locate( "NONAME-", em) .ne. f$len(em) then goto lp $ write sys$output "''p1' is ''em'" ! YES print the error message $ goto lp $done: $ exit $ ! allen rueter 314/935-6429 $ ! allen282 gmail.com ! sys$message:climsgtbl <*
15) Is it a holiday? $ ! make a logical setting the holiday true or false $ if f$mode() .eqs. "BATCH" ! as opposed to sys$systartup_vms.com $ then subm holidays/aft=tom/noprint/que=sys_stuff $ endif $weekend: today = f$edit(p1,"UPCASE") ! for debugging/over-ride $ if today .eqs. "" then today := TODAY $ $! HOLIDAYS.DAT FORMAT IS DD-MMM, where dd can also be 1m !< $! 1M for 1st monday or 4T for 4th thursday $ $ open h sys$manager:holidays.dat/read $ t_dd = f$cvti( today,, "day") ! today's day $ t_mmm = f$cvti( today, "absolute", "month") ! month (Jan) $ t_mm = f$cvti( today, , "month") ! month (01) $ t_dow = f$extr(0,2, f$cvti( today,, "weekday")) ! Su(nday) $ ldom = f$extr( (t_mm-1)*2,2, "312831303130313130313031") ! last day of month $ if ldom .eq. 28 then ldom = f$str(31-f$cvti( "28-feb+1-",,"month")) ! leap y? $ t_ddmmm = t_dd+"-"+t_mmm $ if f$len(t_dd) .eqs. 1 then t_ddmmm = "0"+ t_dd+ "-"+ t_mmm $ m1 = "False" $ t4 = "False" $ ml = "False" $ if t_dow .eqs. "Mo" .and. t_dd .ge. 1 .and. t_dd .le. 7 then m1 = "True" $ if t_dow .eqs. "Th" .and. t_dd .ge. 22 .and. t_dd .le. 28 then t4 = "True" $ if t_dow .eqs. "Mo" .and. t_dd .ge. ldom-6 .and. t_dd .le. ldom then lm="True" $lp: $ read h ddmmm/end=workn ! read in holidays $ ddmmm = f$edit( ddmmm, "UNCOMMENT,UPCASE") $ if t_ddmmm .eqs. f$extr(0,6, ddmmm) then goto happy $ if t_mmm .eqs. f$extr(3,3, ddmmm) $ then dd = f$extr( 0, 2, ddmmm) $ if m1 .and. dd .eqs. "1M" then goto happy $ if t4 .and. dd .eqs. "4T" then goto happy $ if lm .and. dd .eqs. "LM" then goto happy $ endif $ goto lp $happy: $ if t_dow .eqs. "Su" .and. today .eqs. "TODAY" $ then set entry '$entry /param=( 'f$cvti(today,"absolute","date")) $ goto workn $ endif $ define/syst holiday true $ set day /secondary ! enforce UAF secondary day restrictions on holidays $ goto good_bye $workn: $ define/syst Holiday false ! usually :-( $ ! if t_dow .eqs. "Fr" .and. today .eqs. "TODAY" then ... ! Banks & Feds $good_bye: $ close h $ exit ! Allen Rueter
16) Squash version numbers $ ! push version numbers down, p1 is the file spec $ p1 = f$elem( 0,";", p1) ! strip version <* $ v0 = f$parse( f$sear(p1+";-0"), ,,"VERSION") - ";" $ if v0 .eqs. "" then exit %x00018290 ! %rms-w-fnf, file not found $ if v0 .eq. 1 $ then write sys$output "Lowest version is one, can't hunker down." $ exit $ endif $ vn = f$elem( 1, ";", f$parse( f$sear(p1+";"), ,,"VERSION")) ! highest $ vd = 1 $ set noon $lp: $ rename 'p1';'v0 'p1';'vd /log $ if $status then vd = vd+1 ! skip over 'holes' $ v0 = v0 +1 $ if v0 .le. vn then goto lp $ vnn = f$parse( f$sear(p1+";"), ,,"VERSION") - ";" ! check for newer ones? $ if vnn .gt. vn $ then vn = vnn $ goto lp $ endif 16b) Find high version numbers $ v = 'f$verify(0) ! find high version numbers $ show device d/moun/out=disks.lis ! get a list of disks $ open md disks.lis ! start reading list of disks $ read md sl/end=have_disks ! blank line $ read md sl/end=have_disks ! device ... $ read md sl/end=have_disks ! name ... $ on control_y then goto have_disks $r: read md sl/end=have_disks $ if f$edit( f$extr( 0,5, sl), "collapse") .eqs. "" then goto r ! skip wrtlck $ on error then goto r $ on severe then goto r $ s = f$extr( 0,12, sl)+"[000000...]*.*" $ ivs = f$edit( s,"collapse") $ write sys$output "working on ",f$parse( ivs, ,,"DEVICE")," ",f$time() $s: fs = f$search(ivs) $ if fs .eqs. "" then goto r $ v = f$parse( ivs, ,,"version") - ";" $ if v .gt. 32000 then write sys$output ivs $ goto s $have_disks: $ close md $ dele disks.lis;/nolog $ exit 1+ 0*f$verify(v)
17) Close to RWASTing?, etc (with out using anal/syst (sda) for non-priv users) $ pid = p1 $ delay = p2 $lp: $ call wnnl 'pid $ call wnnl " AST ''f$getj(pid,"ASTCNT")'/''f$getj(pid,"ASTLM")' " $ call wnnl " BIO ''f$getj(pid,"BIOCNT")'/''f$getj(pid,"BIOLM")' " $ call wnnl " BYT ''f$getj(pid,"BYTCNT")'/''f$getj(pid,"BYTLM")' " $ call wnnl " DIO ''f$getj(pid,"DIOCNT")'/''f$getj(pid,"DIOLM")' " $ call wnl $ call wnnl " ENQ ''f$getj(pid,"ENQCNT")'/''f$getj(pid,"ENQLM")' " $ call wnnl " FIL ''f$getj(pid,"FILCNT")'/''f$getj(pid,"FILLM")' " $ call wnnl " PRC ''f$getj(pid,"PRCCNT")'/''f$getj(pid,"PRCLM")' " $ call wnnl " TQ ''f$getj(pid,"TQCNT")'/''f$getj(pid,"TQLM")' " $ call wnnl " PFQ ''f$getj(pid,"PagFilCnt")'/''f$getj(pid,"PgFlQuota")' " $ if f$len(delay) $ then wait 'delay $ goto lp $ endif $ exit $ wnnl: subroutine $ read/time=0 sys$output jnk /error=wnnle /prom="''p1'" $wnnle:$ exit $ endsubroutine $ wnl: subroutine $ crlf[0,16]=2573 $ read/time=0 sys$output jnk /error=wnle /prom="''crlf'" $wnle:$ exit $ endsubroutine
18) TODR_REST $ ! fix bug/feature of Time-of-Day Register vs sys.exe time $ ! after 15 months, TODR can get out of sync with sys.exe $ $ year = f$cvtime(,,"year") ! get current year $ nxtyear = f$str(year + 1) $ set time ! sync todr with sys.exe $ nxtime := 1-jan-'nxtyear':00:04:00 $ subm /aft='nxtime' sys$manager:todr_reset/noprint /queue=sys_stuff $ exit ! install/upgrade over a year after release
19) CHECK_LICE ( look for licenses that are about to expire) $ subm/que=sys_stuff check_lice /aft="tod+3-" /noprint $ show license /brief /output=active.licenses $ open f active.licenses/read $ read f blank_line $ read f title $ read f blank_line $ read f column_hdr1 $ read f column_hdr2 $ expflg = 0 $lp: !Product Producer Units Avail Activ Version Release Termination $ read f ll /end=clean_up $ ll = f$edit(ll,"compress") $!DVNETEND DEC 0 0 100 0.0 (none) 31-JAN-1997 $ exp = f$elem(7," ",ll) $ if exp .eqs. "(none)" then goto lp ! I like this kind $ ! snce you can't subtract two absolute times in dcl, the next best thing ... $ if f$cvti("''exp'-30-") .lts. f$cvti("today") then expflg = 1 $ goto lp $ $clean_up: $ close f $ if expflg $ then mail active.licenses sysmgr /subj="something expiring this month?" $ ! mail set forw/user=sysmgr actual_user < $ mail active.licenses sysmgr2 /subj="something expiring this month?" $ endif $ dele active.licenses;
20) Push - Yet another 'cd' utility ( push :== @sys$common:[usrcom]pushdef ) $ old_verify = 'f$verify(0)' $top: $ if p1 .eqs. "" then goto no_argument $ if p1 .eqs. "B" .or. p1 .eqs. "BA" .or. p1 .eqs. "BACK" - then goto setup_Pushback $ on_with_it: $ Olddefault := 'f$trnlnm("SYS$DISK")''f$directory()' $ if f$length(f$trnlnm(p1)) .gt. 0 then goto old_style $ if f$locate(":",p1) .ne. f$length(p1) then goto old_style $ if f$locate("[",p1) .ne. f$length(p1) then goto old_style $ if f$locate("<",p1) .ne. f$length(p1) then goto old_style $ if f$locate("&",p1) .ne. f$length(p1) then goto ampersand $ if f$extr(0,1,f$directory()) .eqs. "[" then p1 = "[" + p1 + "]" ! <* $ if f$extr(0,1,f$directory()) .eqs. "<" then p1 = "<" + p1 + ">" $ old_style: $ if f$parse( p1) .eqs. "" then exit %x18292+0*f$verify(old_verify) $ampersand: $ set default 'p1' ! <* & in push b $ If .not. $status then goto push_exit $ psh_tmp := 'Psh_index' $ if psh_tmp .eqs. "" then psh_index == 0 $ psh_index == psh_index+1 $ psh$_default'psh_index' :== 'olddefault' $ if f$mode() .nes. "BATCH" then $Show default $ Goto push_exit $ no_argument: $ inquire p1 "What" $ goto top $ setup_pushback: $ if psh_index .lt. 1 then goto invalid_pushback $ p1 := &psh$_default'psh_index' ! <* $ if p2 .nes. "" then p1 := &psh$_default'p2' $ write sys$output p1," ",p2 $ goto on_with_it $ invalid_pushback: $ write sys$output "?Nothing to PUSH BACK to" $ Goto Push_exit $ push_exit: $ exit 1 +0*f$verify(old_verify)
21) Pop [t][i] ( pop :== @sys$common:[usrcom]popdef ) $ old_verify = 'f$verify(0)' $ if f$type( psh_index) .eqs. "" then psh_index == 0 ! exist? $ index_end = 0 $ if f$extract(0,1,p1) .eqs. "T" then goto trace_default_stack $ inquire_on = "''F$Extract(0,1,p1)'" .eqs. "I" $ if inquire_on .then goto on_with_it $ if p1 .gt. psh_index then goto bad_return_value $ if p1 .lt. 1 then p1 = 1 $ index_end = p1-1 $on_with_it: $ if psh_index .eq. 0 then goto no_prior_push $popit: $ prevdefault := "PSH$_DEFAULT"'PSH_INDEX' $ newdefault := &'prevdefault' $ if .not. inquire_on then goto set_default $ write sys$Output "Next stop: ",'prevdefault' $ inquire/nopunct set_response " --> Go for it (Y or N
22) Show framented files, (avoid sales calls, from you know who) $ ! Find fragmented files p1 - disk:, p2 - show files with more than p2 frags $ if f$len(p1) .lt. 2 then read/prom="_Disk: " p1 $ if p2 .eq. 0 then p2 =7 $ isz = f$file(p1+"[0,0]indexf.sys","eof") $ write sys$Output "There are ", isz, " blocks in indexf.sys." $ clusz = f$getdvi( p1, "cluster") $ maxfil = f$getdvi( p1, "maxfiles") $ bmsz = maxfil/4096+1 ! bit map size $ open i 'p1'[0,0]indexf.sys/read /shar=write $ hb = clusz*3+ clusz ! home blocks & copies of fid(1,1,0) $ call skipb 'hb $ call skipb 'bmsz ! it would be better to read in the bit map but .... $ on control_y then goto fini ! so we close indexf.sys $fndi: $ read i hdr/end=fini $ fid = f$cvui( 8*8,32,hdr) ! make sure we got to fid 1,1,0 $ if fid .ne. %x10001 .or. f$extr(%x50,10,hdr) .ne. "INDEXF.SYS" $ then write sys$output "hmm ",f$fao("!XL",fid), " ", f$extr(%x50,10,hdr) $ goto fndi ! find 1,1 indexf.sys $ endif $ write sys$output " FID Frags size Name" $ f=1 $lp: $ fid = f$cvui( 8*8,16,hdr) $ mapoff = f$cvui( 8, 8, hdr) ! map offset 100 for 1st, 50 for rest? $ if fid .eq. 0 .or. mapoff .ne. 100 then goto rd_nxt $ fid1= f$cvui( 8*10, 16, hdr) ! recycle count $ fidv= f$cvui( 8*12, 16, hdr) ! volume $ fide= f$cvui( 8*14, 16, hdr) ! extention fid => really bad $ rb = f$cvui( 8*%x3a, 16, hdr) ! number of retrieval words $ fn = f$extr( %x50, 20, hdr) ! file name $! fn2 = f$extr( %x86, 30, hdr) ! file name2, more like 66 $ alq = f$cvui( 8*%x1a, 32, hdr) ! allocated space $! if rb/2 .gt. p2 then - $ write sys$output - f$fao("(!5UW,!3UW,!2UW) !3UW !7UL ",fid,fid1,fidv,rb/2,alq),fn !,fn2 $ if fide .ne. 0 then write sys$Output fn," is really bad!" $rd_nxt: $ read i hdr/end=fini $ f = f+1 $ if (f .and. 255) .eq. 0 then write sys$output f," headers checked." ! low rpm $ goto lp $fini: $ close i $ exit ! allen Rueter allen282 gmail.com $ $skipb: subroutine $ write sys$Output "skipping ",p1," blocks" $next: $ read i hdr $ p1 = p1-1 $ if p1 .gt. 0 then goto next $ endsubroutine
23) Queue_cleaning $ ! Clean out all retain on errors entries 14Nov94 sdt (corrected) $ $ t = f$getqui("CANCEL_OPERATION") ! reset wildcard operations $qlp: ! don't do show queue ... $ qn = f$getqui("DISPLAY_QUEUE", "QUEUE_NAME", "*", - "wildcard,PRINTER,TERMINAL") ! any device queue $ if qn .eqs. "" then exit ! all done when empty $ r = f$getqui("DISPLAY_QUEUE","RETAINED_JOB_COUNT","*",- "wildcard,freeze_context") ! same queue again < $ if r .eq. 0 then goto qlp $ write sys$output qn," has retained entries." $JobLoop: $ e = f$getqui("DISPLAY_JOB", "ENTRY_NUMBER",, "ALL_JOBS") ! < $ if e .eqs. "" then goto qlp $ delete/log/entry='e $ ! show entry 'e $ goto JobLoop ! by Allen Rueter, allen282 gmail.com
24) Cheap VMS upgrade $ if f$getsyi("VERSION") .eqs. "V5.4-2 " then goto doit $ write sys$output "This update may only be run on VMS Version V5.4-2." $ exit $doit: $ on warning then exit $ default = f$envi("default") $ set defa sys$common:[sys$ldr] $ patch sys.exe ! ! Patch system version id ! define sys$gq_veraddr=800044b8 define sys$gq_bladdr=800044bc deposit /asc sys$gq_veraddr="V7.0" deposit /asc sys$gq_bladdr=" " update exit $ write sys$output "The next time you reboot, you will be running V6.0." $ set def 'default $ exit ! abuse the net / cheap 'cluster' $ TYPE/PAGE 0::"TASK=SHOW_SYST" $ ! show_syst.com $ define sys$output sys$net: $ show system $ exit
25) Mass queue entry delete $ ! p1 - queue name, p2 username 14Nov94 sdt $ ! Clean up program generated submits (computer assisted mistakes) $ $ t = f$getqui("CANCEL_OPERATION") ! reset wildcard operations $ t = f$getqui("DISPLAY_QUEUE", "PENDING_JOB_COUNT", "''P1'", - "ALL_JOBS, WILDCARD") ! any user $ if t .eq. 0 then exit ! none found, quit $ n = f$getqui("DISPLAY_JOB", "USERNAME",, "ALL_JOBS") ! for that queue ... $JobLoop: $ if n .eqs. P2 $ then $ e = f$getqui("DISPLAY_JOB", "ENTRY_NUMBER",, - "ALL_JOBS, FREEZE_CONTEXT") ! same entry < $ delete/log/entry='e' $ ! show entry 'e $ endif $ n = f$getqui("DISPLAY_JOB", "USERNAME",, "ALL_JOBS") $ if n .eqs. "" then exit $ goto JobLoop ! by Tom Leith, trl@wuerl.wustl.edu
26) Subtract times in DCL $ ! subtract absolute times, p1 - p2, returns symbol delta_time $ if f$cvti(p1,,) .lts. f$cvti(p2,,) ! put larger time in p1 $ then sign="-" $ px = p1 $ p1 = p2 $ p2 = px $ else sign=" " $ endif $ dtin = f$cvti(p1,,"date") $ gosub juliandt ! calculate julian date $ j1 = jdtout $ dtin = f$cvti(p2,,"date") $ gosub juliandt $ j2 = jdtout $ b:=100,60,60,24 ! how much to borrow $ t:=HUNDREDTH,SECOND,MINUTE,HOUR ! field to get $ d=".!2ZL,:!2ZL,:!2ZL,-!2ZL," ! time delemeters $ i=0 ! index $ brw = 0 ! uncarry $ dt = "" ! temp delta time $lp: t1 = f$int( f$cvti(p1,,f$elem(i,",",t))) ! extract part $ t2 = f$int( f$cvti(p2,,f$elem(i,",",t))) $ t3 = t1 - t2 - brw ! calculate $ if t3 .lt. 0 ! underflow? $ then t3 = t3+ f$elem( i, ",", b) ! borrow $ brw = 1 $ else brw = 0 $ endif $ dt = f$fao( f$elem(i,",", d), t3)+ dt ! build delta time $ i = i+1 $ if f$elem( i,",", b) .nes. "," then goto lp $ delta_time = sign+ f$str( j1-j2-brw)+ dt $ write sys$output delta_time $ exit $juliandt: $ y = f$int( f$elem(0,"-",dtin)) $ m = f$int( f$elem(1,"-",dtin)) $ d = f$int( f$elem(2,"-",dtin)) $ if m .lt. 3 then y = y - 1 ! work around jan/feb leap years $ if m .lt. 3 then m = m + 12 ! work around jan/feb leap years $ ms:=0,31,61,92,122,153,184,214,245,275,306,337 $ jdtout == y*365+ y/4- y/100+ y/400+ f$elem( m-3,",",ms)+ d $ return
27) Finding sortwork space. (disk with most free space) find-sortwor... $ v = 'f$verify(0) ! Find SortWork Space $ show device d/moun/out=disks.lis ! get a list of disks $ big = 0 ! initialize $ bigger = 0 $ biggerdsk = "" $ bigdsk = "" $ open md disks.lis ! start reading list of disks $ read md sl/end=have_disks ! blank line $ read md sl/end=have_disks ! device ... $ read md sl/end=have_disks ! name ... $r: read md sl/end=have_disks $ if f$edit(f$extract(0,5,sl),"collapse") .eqs. "" then goto r ! skip wrtlck $ on error then goto r $ on severe then goto r $ d = f$extract(0,12,sl)+"[0,0]sortwork.dir" ! do we allow sortwork here? $ d = f$edit(d,"collapse") $ if f$search(d) .eqs. "" then goto r $ dsk = f$edit(f$extract(0,12,sl),"collapse") ! yes, how many free blocks $ fb = 'f$getdvi(d,"freeblocks") $ if fb .gt. bigger $ then big = bigger ! new biggest disk $ bigdsk = biggerdsk $ bigger = fb $ biggerdsk = dsk $ else $ if fb .gt. big $ then big = fb $ bigdsk = dsk $ endif $ endif $ goto r $have_disks: $ close md $ delete disks.lis;/nolog $ v = f$verify(v) ! set up sortwork logicals $ define sortwork0 'bigdsk'[sortwork] $ define sortwork1 'biggerdsk'[sortwork] $ exit
28) Disk space watcher. $ ! check for disk space $ interval = 3 ! hours $ subm/noprint/que=sys_stuff disk_check /aft="+''interval':00" $ $ open d2c disk2check.dat/read $ open d3c disk2check.dat/write $ set noon $lp: $ read d2c items /end=part2 ! disk,leadtime,freeblocks $ disk = f$elem(0,",",items) $ leadtime = f$elem(1,",",items) $ ofreeblks= f$elem(2,",",items) $ freeblks = f$getdvi( disk, "freeblocks") $ write d3c disk,",",leadtime,",",freeblks $ bph = ( ofreeblks-freeblks)/interval ! blocks per hour $ x = freeblks - bph*leadtime $ if x .lt. 0 $ then y = freeblks/bph $ sbj="In ''y' hours ''disk' may run out of space!" $ mail nl: allen/subj="''sbj'" $ mail nl: radman/subj="''sbj'" $ endif $ goto lp $part2: ! finish part 1 first $ close d2c $ close d3c $ purge disk2check.dat $ hr = f$cvti(,,"hour") $ if hr .ge. 2 .and. hr .le. 5 then goto fini_part2 $ open ss2c shadowsets2check.dat/read $ set noon $lp2: $ read ss2c item /end=fini_part2 $ mbr1 = f$getdvi(item,"shdw_next_mbr_name") $ mbr2 = f$getdvi(mbr1,"shdw_next_mbr_name") $ if f$len( mbr2) .gt. 0 then goto lp2 $ sbj="shadow set ''item' has only one member!" $ mail nl: allen /subj="''sbj'" $ mail nl: radman /subj="''sbj'" $ goto lp2 $fini_part2: $ close ss2c $ purge/log/keep=4 disk2check.dat $ if f$pars( f$sear( "disk2check.dat;-3"), ,,"version") .gt. 1 $ then $ rename disk2check.dat;-3 disk2check.dat;1 $ rename disk2check.dat;-2 disk2check.dat;2 $ rename disk2check.dat;-1 disk2check.dat;3 $ rename disk2check.dat; disk2check.dat;4 $ endif $ exit sys$sysdevice:,72,509468
29) DCL mischif $ dir* :== write sys$output """%DIRECT-W-NOFILES, no files found""!" $ t = f$trnl("sys$input") $ if f$len(t) .ne. f$locate( "OPA0",t) $ then oldprompt = f$env("prompt") $ set :== set prompt=""">>> "" !" $ endif $ set command/dele=(logout,eoj,stop) ! Dave Rathnow $ set command/dele=set ! really mean $ READ /Key="April Fool!" sys$command result ! David L. Cathey $ WRITE SYS$OUTPUT F$FAO("!#ZL-Apr-1996", "Fool", 1) ! Stuart Palin $ ! Disable symbol subsitution $ SET SYMBOL/SCOPE=(NOLOCAL,NOGLOBAL)/VERB ! Steve Sparrow
30) re-entrant .com file to trap goto errors. sdt.apr94 $ SET NOON $ SET NOCONTROL=Y $ SET CONTROL=T $ if f$len(p1) then goto opt_'p1 ! nifty re-entry to trap goto errors $menu: $ type /page nl: ! clear screen $ say :== write sys$output $ say "" $ say " Main Menu" $ say "" $ say " 1. option 1 " $ say "" $ say " 2. option 2 " $ say "" $ say " 3. option 3 " $ say "" $ say " 4. Logoff." $ say "" $ read sys$output ans/prompt="Enter a number: "/error=rd_err/timeout=120 $ @re-entrant 'ans $ goto menu $rd_err: ! %X000181B0 %RMS-W-TMO, timeout period expired $ if f$mess($status,"IDENT") .eqs. "%TMO" then goto logout $ show sym $status $ wait 00:00:02 $ goto menu $opt_1: $ ! do option 1 $ exit $opt_2: $ ! do option 2 $ exit $opt_3: $ ! do option 3 $ exit $opt_4: $ ! do option 4 $LOGOUT: $ eoj = "" ! Make sure we get real STOP command $ eoj
31) Calculate good friday/easter $! from HOLIDAY.COM by G Burns $ day = f$integer( f$cvtime( p1,,"day")) $ mon = f$edit( f$cvtime( p1,"absolute","month"), "upcase") $ year = f$integer( f$cvtime( p1,,"year")) $ weekday = f$edit( f$cvtime( p1,,"weekday"), "upcase") $ $ HOLIDAY == 0 $ $ if weekday .nes. "FRIDAY" then $ exit ! It can't be Good Friday. $ if day .LT. 21 .and. - mon .eqs. "MAR" then $ exit ! Prior to earliest possible Good Friday. $ if day .GT. 23 .and. - mon .eqs. "APR" then $ exit ! After the latest possible Good Friday. $ $ PASCHAL_FULL_MOON_LIST = "14032311311808281605251302221030170727" $ GOLDEN_NUMBER = year - ( ( year / 19 ) * 19 ) $ OFFSET = 2 * GOLDEN_NUMBER $ PASCHAL_FULL_MOON_DATE = F$EXTRACT( OFFSET,2,PASCHAL_FULL_MOON_LIST) $ PASCHAL_FULL_MOON_MONTH = "APR" $ if PASCHAL_FULL_MOON_DATE .GT. 20 then PASCHAL_FULL_MOON_MONTH = "MAR" $ $! Easter follows the Paschal Full Moon, the first Full $! Moon following the Spring equinox, by 1 to 7 days, the $! first Sunday following the Paschal Full Moon. $! Good Friday will fall from 1 day preceding to 5 days $! following the Paschal Full Moon. $ $ if mon .eqs. PASCHAL_FULL_MOON_MONTH then goto SAME_MONTH $ $! ELSE Paschal Full Moon is in different month than this. $ $ if mon .eqs. "APR" then PASCHAL_FULL_MOON_DATE=PASCHAL_FULL_MOON_DATE-31 $! then Paschal Full Moon month is MARCH, convert the $! Paschal Full Moon date to a "APRIL date". $ if mon .eqs. "MAR" then PASCHAL_FULL_MOON_DATE=PASCHAL_FULL_MOON_DATE+31 $! then Paschal Full Moon month is APRIL, convert the $! Paschal Full Moon date to a "MARCH date". $ $ SAME_MONTH: $ $ if day .GT. PASCHAL_FULL_MOON_DATE + 5 then $ exit $ if day .LT. PASCHAL_FULL_MOON_DATE - 1 then $ exit $ holiday == 1 $ exit $ $ exit ! HOLIDAY.COM
32) What was last friday? $ ! last_dow.com $! return date of previous day where p1 = day $ pday = f$edit( f$extr(0,1,p1),"UPCASE")+f$edit(f$extr(1,1,p1),"LOWERCASE") $ today = F$extr(0,2,f$cvti(,,"weekday")) $ wds ="SaFrThWeTuMoSuSaFrThWeTuMo" $ daysbacks = f$extr( f$locate(today,wds)+2, 14, wds) ! get last 7 days $ daysback = f$locate(pday,daysbacks )/2 +1 ! calc offset $ write sys$output "Last ",p1," was ",- f$cvti("today-''daysback'-","absolute","DATE") $ exit
33) Multi line reply T FLores & DSNLINK $ CR[0,8] = 13 ! create a symbol to represent a CR $ LF[0,8] = 10 ! create a symbol to represent a LF $ duhmsg = - " This is line 1 ''CR'''LF' This is line 2 ''CR'''LF' This is line 3" $! $ REPLY/USER=username "''duhmsg'" $ exit or $ duhmsg = F$FAO("!AS!/!AS!/!AS", "Line 1", "Line 2","line3") $REPLY/USER=username "''duhmsg'" or a line liner $ REPLY/USER=username "''F$FAO("!AS!/!AS!/!AS", "Line 1", "Line 2","line3")'"
SM31) If you have Binary Time in symbol $ time_stamp[0,32] = %xe2dee620 $ time_stamp[32,32]= %x009af20e you can write it out with $ write sys$output F$FAO("!%D", F$CVUI( 32,32, F$FAO("!AD",8,TIME_STAMP))) ! Skip Morris
SM40) DCL Binary access to ISAM files $ open/read file isam.dat ! /write is optional, /error recomended : : $ key="1234" ! make a longword $ key[0,32] = record_number ! insert binary number $ read/key=&key file record ! pass key postpone substition if the key has a quote in it ... $ pad_bin_key: ! argument is key, returns str $ n = 0 $ str = "" $ quote = """" $ scan: $ next_piece = f$element( n, quote, key) $ if next_piece .eqs. quote then goto done $ if n .gt. 0 then str = str + quote + quote $ str = str + next_piece $ n = n+1 $ goto scan $ done: ! Skip Morris
xx) hsz_what_is.com ! get more info about and hsz device $ ! p1 is the vms dvice to queried, p2 is the returned symbol $ ! prevpriv = f$setprv("diag,phy,sysp,volp,cmk,sysl") $ if .not. f$getdvi( p1, "exists") then exit $ if p2 .eqs. "" then p2 := hsz_it_is $ qu = f$getdvi( p1, "unit") $ write sys$output "will query ''p1'(D''qu')" $ tmpfil = "hsz_what_is_"+f$getjpi("","pid")+".tmp" $ defi/user sys$output 'tmpfil $ set host/scsi 'p1 show d'qu $hszopnlg: $ open hszlg 'tmpfil'; /read/err=opnerr $hszplp: ! find hsz> $ read hszlg ln /err=hszperr $ if f$extr(0,4, ln) .nes. "HSZ>" then goto hszplp $ uname = "D"+f$str(qu) $ unl = f$len(uname) $! sho sym uname $hszulp: $ read hszlg ln $! sho sym ln $! say f$extr(2,unl,ln) $ if f$extr(2,unl, ln) .nes. uname then goto hszulp $ ln = f$edit( ln, "compress") $ cr[0,8]=13 $ 'p2 :== 'f$elem( 0, cr,f$elem( 2," ",ln)) $ say p1," is ",uname," which is ", 'p2 $ close hszlg $ dele/nolog 'tmpfil';* $ exit $opnerr: $ s =$status $ write sys$output f$mess(s) $ 'p2 :== f$mess(s) $ exit s $hszperr: $ s = $status $ write sys$output f$mess(s) $ 'p2 :== f$mess(s) $ close hszlg $ exit s
xx) hsz_what_makes.com ! so it was a stripe/shadow set, what makes that? $ ! p1 is the vms device to queried, $ ! p2 is the virtual device $ ! p3 is the returned symbol /type/member[:member]/switches[:switches]/states/ $ if .not. f$getdvi( p1, "exists") then exit $ if p2 .eqs. "" then exit $ if p3 .eqs. "" then p3 := hsz_it_is $ qu = f$getdvi( p1, "unit") $ write sys$output "will query ''p2' via ''p1'(D''qu')" $ tmpfil = "hsz_what_makes_"+f$getjpi("","pid")+".tmp" $ defi/user sys$output 'tmpfil $ set host/scsi 'p1 show 'p2 $hszopnlg: $ open hszlg 'tmpfil /read/err=opnerr $hszplp: ! find hsz> $ read hszlg ln /err=hszperr $ if f$extr(0,4, ln) .nes. "HSZ>" then goto hszplp $ uname = "D"+f$str(qu) $ unl = f$len(uname) $ sho sym uname $ read hszlg ln ! get column titles, calc offests $ nameoff = f$locate( "Name", ln) $ storoff = f$locate( "Storageset", ln) $ usesoff = f$locate( "Uses", ln) $ read hszlg ln ! skip dashes $ read hszlg ln ! skip blank line $ name = "" $ stor = "" $ uses = "" $ swit = "" $ stat = "" $ cr[0,8]=13 $hszulp: $ read hszlg ln/err=hszuerr $ ln = f$elem(0, cr, ln) ! strip cr $ lln = f$len(ln) $! sho sym ln $ if f$locat( "Switches:", ln) .nes. f$len(ln) then goto switches $ if name .eqs. "" then name = f$elem( 0, " ",f$extr( nameoff, lln, ln)) $ if stor .eqs. "" then stor = f$elem( 0, " ",f$extr( storoff, lln, ln)) $ uses = uses + f$elem( 0, " ", f$extr( usesoff, lln, ln)) + ":" $ goto hszulp $switches: $ read hszlg ln/err=switcherr $ ln = f$elem(0, cr, ln) $! sho sym ln $ if f$locat( "State:", ln) .nes. f$len(ln) then goto states $ swit = swit + f$edit( ln,"compress") + ":" $ goto switches $states: $ read hszlg ln/err=stateerr $ ln = f$elem(0, cr, ln) $ sho sym ln $ if f$locat( "Size:", ln) .nes. f$len(ln) then goto sizes $ stat = stat + f$edit( ln,"compress") + ":" $ goto states $sizes: $ 'p3 == name+"/"+stor+"/"+uses+"/"+swit+"/"+stat+"/" $ say p1," is ",uname," which is ", 'p3 $ close hszlg $ dele/nolog 'tmpfil';* $ exit $opnerr: $ s = $status $ write sys$output f$mess(s) $ 'p3 == f$mess(s) $ exit 's
hits.