Collection of Tools & Utilities/Collection of Tools and Utilities.iso/batchut/rap101.zip/COMMON.RAP

Text File | 1989-05-10 | 19.1 KB | 818 lines

; common.rap  v1.01  compacted version - copyright 1988 SIL - 10 May 1989
#verbose=1
if ($screentype == "Sharp LCD")
$skip=$null
else
$skip=$newline*chr(13)
endif
$valdr=*getdr__()
#help__= -1
$helpfile__=
$dospath__=$path
proc error($message,$topic)
declare $tag,$indent
declare $left,$match,$right
if (not ($message contains "[.!?]$"))
$message=$message.
endif
if ($message contains "^[ \\t][ \\t]*")
$indent=$match
endif
t:$skip*chr(7)$message\
if ($topic == "")
$tag=Try again.
else
$tag=Try again.  (Type ? for help.)
endif
if ((*strlen($message) + *strlen($tag)) > 72)
t:
t:$indent\
else
t:  \
endif
t:$tag
endproc
proc warning($message)
if (not $message has "\\.?!$")
$message=$message.
endif
t:$skip*chr(7)$message.
kbflush()
foot
endproc
proc mount_volume($drive,$id,$name,$topic)
declare $volname,#fd,#case,#opentest,#reopen_help
loop
$volname=*volume($drive)
exit if ($volname == $id)
if (not #opentest)
#opentest = 1
#fd = *open("nul")
close #fd
if (#fd > 1 or (#fd > 0 and #help__ == -1))
t:*chr(7)
t:The program needs to change disks so that the $name
t:disk is accessible, but it is not safe to do so because the program has
t:one or more files open.
t:
if ($topic <> "")
explain($topic)
else
t:   The program must terminate immediately.  Please report this
t:   message to the program's author.
endif
foot
bye
endif
endif
if (#help__ >= 0)
close #help__
#help__ = -1
#reopen_help = 1
endif
t:$skip\Put the $name disk in drive $drive.
kbflush()
foot:Press RETURN after you have done this.
endloop
if (#reopen_help)
reopen_help__()
endif
endproc
proc panic__($location,$msg)
declare #paged
t:*chr(7)$skip\Internal error in \*$location:
t:
t:    $msg
t:
t:The program will continue to run, but the results may not be valid.
t:Copy this message exactly, so you can report it to the program's author,
t:and exit as soon as possible.  You may exit immediately by typing
t:Ctrl-C.
kbflush()
foot
endproc
proc kbflush()
declare $junk
loop while (*keypress())
as $junk
endloop
endproc
strfunc getdr__()
declare $drvlist,$tmp,#case,#tmp
declare $left,$match,$right
if ($cmdline contains "[-/]drive=[ \\t]*")
$drvlist=$right
if ($drvlist contains "[ \\t]")
$drvlist=$left
endif
return $drvlist
endif
if ($screentype == "Sharp LCD")
if (*freesp("P") == -1)
return "ABCDG"
else
return "ABCDGP"
endif
else
$drvlist=AB
$tmp=C
loop while (*freesp($tmp) > 0)
$drvlist=$drvlist$tmp
#tmp = *ascii($tmp) + 1
$tmp=*chr(#tmp)
endloop
return $drvlist
endif
endfunc
proc explain($topic)
declare #case,$line
declare $left,$match,$right
if (not #verbose)
return
else if (#help__ < 0)
t:There is no help-file available to this program.
foot
return
endif
seek #help__,2
loop while ($line <> "End of file.")
read #help__,$line
exit if (not ($line contains ":"))
exit if ($left == $topic)
endloop
if ($line == "End of file." or $left <> $topic)
t:Sorry, there is no information on <$topic> in the help file.
foot
return
endif
seek #help__,*value($right),bytes
loop
read #help__,$line
exit if ($line == "End of file.")
if (not ($line has "^\\\\"))
t:$line
else if ($line=="\\cls")
cls
else if ($line=="\\foot")
foot
else if ($line has "^\\\\topic[ \\t]")
exit
else
t:$line
endif
endloop
endproc
strfunc get_filespec($query,$defpath,$defname,$defext,$topic)
declare $answer,$left,$match,$right,#case,$default,$defdrive
$drive=
$subdir=
$name=
$ext=
$defext=*ensure_dot($defext)
if ($defpath <> "")
if (not ($defpath has "[:\\\\]$"))
$defpath=$defpath\\
endif
endif
$default=$defname$defext
if ($default <> "")
$query=$query [$default]
endif
loop
$answer=*get_ans("$query (type DIR for directory):","",$topic,not +
*strlen($default))
if (($answer == "") and ($default == $defext))
error("  Your answer must always include a filename part.",$topic)
repeat
else if ($answer == "")
$answer=$defpath$defname$defext
else if ($answer contains "^[ \\t]*dir\[ \\t]*")
show_dir__($right,$defpath,$defext)
repeat
endif
if (not ($answer has "[\\\\:]"))
$answer=$defpath$answer
endif
if (*parse_filespec($answer,1,$topic))
if ($ext == "")
$ext=$defext
endif
return "$drive$subdir$name$ext"
endif
endloop
endfunc
strfunc get_input_file($query,$defpath,$defname,$defext,$topic)
declare #case,#verbose,$filespec
declare $oldname
#verbose=1
loop
$filespec=*get_filespec($query,$defpath,$defname,$defext,$topic)
#filesize=*filesize($filespec)
if (#filesize < 0)
error("  $filespec does not exist.",$topic)
else
#filesize=(#filesize+1023)/1024
if (($ext == ".TMP") or ($ext == ".BAK"))
t:*chr(7)An input file may not have a TMP or BAK extension.
repeat if (*no("Do you want to rename the file to a different+
extension","",""))
$oldname=$filespec
loop
$ext=*get_str("New extension for $oldname","","",1,4,1)
$ext=*ensure_dot($ext)
$filespec=$drive$subdir$name$ext
if (not *val_ext($ext,$topic))
repeat
else if (($ext == ".TMP") or ($ext == ".BAK"))
error("  You must rename the extension to something besides TMP or BAK.",$topic)
else if (not *existf($filespec))
exit
endif
t:*chr(7)$filespec already exists.  Try a different extension.
endloop
xs ren $oldname $name$ext
endif
return $filespec
endif
endloop
endfunc
strfunc get_output_file($query,$defpath,$defname,$defext,$topic,#size)
declare $filespec,#case
loop
$filespec=*get_filespec($query,$defpath,$defname,$defext,$topic)
if (*delq($filespec) <> 4)
ensure_space($drive,$subdir,#size)
return $filespec
endif
endloop
endfunc
proc ensure_space($dr,$subdir,#size)
declare #need
declare $spare
declare $delname
declare $path
declare $name,$ext
declare $drive
declare #attr
if (#size < 1)
return
else if ($dr == "")
$dr=*currdriv():
else
$dr=*to_upper("*mid($dr,1,1)"):
endif
loop
#need=#size-(*freesp($dr)/1024)
exit if (#need < -10)
if (#need > 0)
t:*chr(7)\
t:
t:There is not enough space for the output file on drive $dr.
t:You need to reclaim at least #need\K of space before proceeding.
else
if (#need == 0)
$spare=absolutely no space
else
#need = (0 - #need)
$spare=only #need\K
endif
t:*chr(7)\
t:
t:Your output file will probably fit on drive $dr, but there is
t:$spare to spare.  If there is a possibility that the output file
t:will grow, it would be wise to make some extra space for the +
output file.
exit if (*no("Do you want to pause to delete some files","y",""))
endif
xs dir $dr$subdir /w /p
get_filespec("File to delete","$dr$subdir","","","")
if (*to_upper($dr) <> *to_upper($drive))
error("  You must delete files on drive *to_upper($dr).","")
else
$delname=$dr$subdir$name$ext
#attr = *deletef($delname)
if (#attr == 0)
t:File $delname not found.
else if (#attr == 4)
t:File $delname is read-only and can't be deleted.
endif
endif
endloop
endproc
strfunc make_tmp_output($file,#size)
declare $left,$right,$match,#case,$path
declare $drive
if ($file contains "\\.[^\\.\\\\]*$")
$file=$left.TMP
else
$file=$file.TMP
endif
if ($file contains ":")
$drive=$left
else
$drive=
endif
if (*deletef($file) == 4)
panic__("make_tmp_output","Need to delete $file but it's read-only")
endif
ensure_space($drive,"",#size)
return $file
endfunc
proc make_bak_file($oldname,$tmpname)
declare $left,$match,$right,#case
declare $bak
if ($oldname contains "\\.[^\\.\\\\]*$")
$bak=$left.BAK
else
$bak=$oldname.BAK
endif
if (*deletef($bak) == 4)
panic__("make_bak_file","need to delete $bak but it's read-only")
else
xs ren $oldname *.BAK
if ($oldname contains "[^:\\\\]*$")
xs ren $tmpname $match
else
warning("Couldn't rename $tmpname to $oldname")
endif
endif
endproc
proc make_bak_to_bat($oldname,$tmpname,#bat)
declare $left,$match,$right,#case
declare $bak
if ($oldname contains "\\.[^\\.\\\\]*$")
$bak=$left.BAK
else
$bak=$oldname.BAK
endif
wr #bat,if exist $bak del $bak
wr #bat,if exist $oldname ren $oldname *.bak
if ($oldname contains "[^:\\\\]*$")
wr #bat,if exist $tmpname ren $tmpname $match
else
warning("Couldn't rename $tmpname to $oldname")
endif
endproc
strfunc ensure_dot($ext)
if ($ext <> "")
if (*mid($ext,1,1) <> ".")
$ext=.$ext
endif
endif
return $ext
endfunc
numfunc val_ext($ext,$topic)
declare $left,$match,$right
if ($ext == "")
return (1)
else if ($ext has "^\\.[a-z0-9_A-Z!@#$%^&()'`{}~\-]*$")
if (*strlen($match) > 4)
error("  No more than 3 characters in extension.",$topic)
else
return (1)
endif
else
error("  Extension contains invalid characters",$topic)
return (0)
endif
endfunc
numfunc val_dir($subdir,$topic)
declare $left,$match,$right
if ($subdir == "" or ($subdir contains "^[\\\\\\.a-z0-9_A-Z!@#$%^&()'`{}~\-][\\\\\\.a-z0-9_A-Z!@#$%^&()'`{}~\-]*$"))
return (1)
else if (*index($subdir,"/"))
error("  Path names use \\, not /.",$topic)
else if ($subdir has "[^\\\\\\.]\\." or $subdir has "\\.[^\\\\\\.]" or $subdir has "\\.\\.\\.")
error("  Dots in subdirectories cannot be mixed with other +
characters.",$topic)
else
error("  Subdirectory name(s) include invalid characters",$topic)
endif
return (0)
endfunc
numfunc val_drive($drive,$topic)
declare #case
if ($drive has "^[$valdr]:$")
return 1
else if ($drive has "^.:$")
error("  Drive *to_upper($drive) does not exist.",$topic)
else if (*index($drive,":"))
error("  Cannot use *to_upper($drive) - must be a disk drive",$topic)
else
error("  Invalid drive designator: $drive",$topic)
endif
return (0)
endfunc
numfunc delq($filespec)
declare $path,#attrib
#attrib = *existf($filespec)
if (#attrib == 0)
return (0)
else if (#attrib == 4)
t:*chr(7)$filespec already exists and can't be deleted.
return (4)
else
t:*chr(7)$filespec already exists.  \
kbflush()
if (*yes("Do you want to overwrite it","",""))
killf $filespec
return (2)
else
return (4)
endif
endif
endfunc
numfunc deletef($file)
declare $path,#attr
#attr = *existf($file)
if (#attr == 4)
return (4)
else if (#attr == 2 or #attr == 1)
killf $file
return (2)
else
return (0)
endif
endfunc
strfunc get_ans($query,$default,$topic,#oblig)
declare $answer, $prompt, #verbose
#verbose = 1
if (not ($query has "[?:]$"))
$query=$query?
endif
if ($default <> "")
$query=$query [$default]
endif
loop
t:$skip$query \
a:$answer
if ($answer == "")
if (#oblig and $default == "")
error("  This question requires an answer.",$topic)
else
return $default
endif
else if ($answer == "?")
if ($topic <> "")
explain($topic)
else
error("  There is no help for this question.","")
endif
else
return $answer
endif
endloop
endfunc
numfunc yes($query,$default,$topic)
declare $answer,#case
loop
$answer=*get_ans($query,$default,$topic,not *strlen($default))
$answer=*trim($answer)
if (($answer == "y") or ($answer == "yes"))
return(1)
else if (($answer == "n") or ($answer == "no"))
return(0)
else
error("  Please type yes or no.",$topic)
endif
endloop
endfunc
numfunc no($query,$default,$topic)
return (not *yes($query,$default,$topic))
endfunc
strfunc get_str($query,$default,$topic,#minlen,#maxlen,#oblig)
declare $answer,#len
if (#minlen > #maxlen)
panic__("get_str","minimum length is greater than maximum length")
#minlen = 0
endif
if (#maxlen < 1)
panic__("get_str","maximum length of zero")
#maxlen = 78
endif
loop
$answer=*get_ans($query,$default,$topic,#oblig)
#len = *strlen($answer)
if (#len < #minlen)
error("  Answer too short - must be at least #minlen characters.",$topic)
else if (#len > #maxlen)
error("  Answer too long - must be #maxlen characters or less.",$topic)
else
return $answer
endif
endloop
endfunc
strfunc get_code($query,$default,$topic,#minlen,#maxlen)
declare $answer,$left,$right,$match,#case
if (#maxlen > 78)
#maxlen = 78
endif
if ($default <> "")
if ($default contains "^\\\\\\\\*")
$default=\\$right
else
$default=\\$default
endif
endif
loop
$answer=*get_str("$query",$default,$topic,#minlen,#maxlen+1,#minlen)
$answer=*trim($answer)
if ($answer contains "^\\\\*")
$answer=$right
endif
if (not ($answer has "^[a-z0-9_]*$"))
error("  Slash code may contain only letters, digits, and _.",$topic)
else if (*strlen($answer) < #minlen)
error("  Code is too short - must be at least #minlen characters (not including \\).",$topic)
else if (*strlen($answer) > #maxlen)
error("  Code is too long - must be no more than #maxlen characters.",$topic)
else
return $answer
endif
endloop
endfunc
numfunc get_num($query,$default,$topic,#min,#max)
declare $string,#number
if ($default <> "")
if (not *isnumber($default))
panic__("getnum","default value is not a number")
$default=
endif
endif
if (#min > #max)
panic__("getnum","minimum is greater than maximum")
#min = (-2147483639)
#max = 2147483639
endif
loop
$string=*get_ans($query,$default,$topic,not *strlen($default))
if (*isnumber($string))
#number = *value($string)
if ((#number >= #min) and (#number <= #max))
return (#number)
endif
endif
error("  Please enter a number between #min and #max.",$topic)
endloop
endfunc
strfunc to_lower($source)
declare $left,$match,$right
declare #case
#case=1
loop while ($source contains "[A-Z]")
$source=$left*chr(*ascii($match)+32)$right
endloop
return $source
endfunc
strfunc to_upper($source)
declare $left,$match,$right
declare #case
#case=1
loop while ($source contains "[a-z]")
$source=$left*chr(*ascii($match)-32)$right
endloop
return $source
endfunc
strfunc trim($source)
declare $left,$match,$right
if ($source contains "^[ \\t][ \\t]*")
$source=$right
endif
if ($source contains "[ \\t][ \\t]*$")
$source=$left
endif
return $source
endfunc
proc show_dir__($spec,$defpath,$defext)
if ($spec <> "")
xs dir $spec
else
if ($defext <> "")
$defext=*ensure_dot($defext)
$defext=*$defext
endif
if ($defpath <> "")
if (not ($defpath has "[:\\\\]$"))
$defpath=$defpath\\
endif
endif
xs dir $defpath$defext /w
endif
foot
endproc
numfunc parse_filespec($filespec,#report,$topic)
$drive=
$subdir=
$name=
$ext=
if ($filespec contains ":")
$drive=$left:
$filespec=$right
if (#report)
if (not *val_drive($drive,$topic))
return (0)
endif
else if (not ($drive has "^[$valdr]:$))
return (0)
endif
endif
if ($filespec contains "\\.[^\\.\\\\]*$")
if (*strlen($match) > 4)
if (#report)
error("  Extension is too long",$topic)
endif
return (0)
else if ($match has "[^\\.a-z0-9_A-Z!@#$%^&()'`{}~\-]")
if (#report)
error("  Invalid character(s) in extension.",$topic)
endif
return (0)
endif
$ext=$match
$filespec=$left
endif
if ($filespec has "[^\\\\\\.]\\." or $filespec has "\\.[^\\\\\\.]" or $filespec has "\\.\\.\\.")
if (#report)
error("  Invalid dots in pathname (only . and .. are valid).",$topic)
endif
return (0)
endif
if ($filespec has "[^a-z0-9_A-Z!@#$%^&()'`{}~\-\\.\\\\]")
if (#report)
error("  Invalid character(s) in subdirectory or filename.",$topic)
endif
return (0)
endif
if ($filespec contains "[^\\\\\\.][^\\\\\\.]*$")
$name=$match
$filespec=$left
$subdir=$left
else
if (#report)
error("  Filename is missing.",$topic)
endif
return (0)
endif
return (1)
endfunc
proc open_help($helpfile)
loop while (not *existf($helpfile))
t:*chr(7)The program's help file ($helpfile) cannot be found.  At this point you may:
t:
menu
option enter the correct location (drive and directory) for the help file.
$helpfile=*get_str("Help-file location","","",0,64,0)
option continue without on-line help available
return
option quit the program now
if (*yes("Are you sure you want to quit","",""))
bye
endif
endmenu
endloop
#help__ = *open($helpfile)
$helpfile__=*findpath($helpfile)
return
endproc
strfunc get_append_file($query,$defpath,$defname,$defext,$topic)
declare #case,#verbose,$filespec,$path
declare $oldname
declare #attrib,#file
#verbose=1
loop
$filespec=*get_filespec($query,$defpath,$defname,$defext,$topic)
#attrib = *existf($filespec)
if (#attrib == 4)
error("  $name$ext is read-only.  You must use a different file.",$topic)
repeat
else if (#attrib == 0)
#file = *open($filespec,"w")
close #file
endif
#filesize=(*filesize($filespec)+1023)/1024
if (($ext <> ".TMP") and ($ext <> ".BAK"))
exit
else
t:*chr(7)An "append" file may not have a TMP or BAK extension.
repeat if (*no("Do you want to rename the file to a different extension","",""))
$oldname=$filespec
loop
$ext=*get_str("New extension for $oldname","","",1,4,1)
$ext=*ensure_dot($ext)
$filespec=$drive$subdir$name$ext
if (not *val_ext($ext,$topic))
repeat
else if (($ext == ".TMP") or ($ext == ".BAK"))
error("  You must rename the extension to something besides TMP or BAK.",$topic)
else if (not *existf($filespec))
exit
endif
t:*chr(7)$filespec already exists.  Try a different extension.
endloop
xs ren $oldname $name$ext
$filespec=$drive$subdir$name$ext
exit
endif
endloop
return $filespec
endfunc
strfunc get_fixed_output($filespec,#size,#allow_sub,$query,$topic)
declare $path
if (*deletef($filespec) == 4)
if (not #allow_sub)
t:*chr(7)
t:This program needs to create an output file named $filespec,
t:but there is an existing file with that name that is read-only.
t:
if ($topic <> "")
explain($topic)
else
t:You must rename or delete the existing copy of
t:$filespec and then rerun this program.
endif
foot
bye
else if (not *parse_filespec($filespec,0,""))
panic__("get_fixed_output","invalid filespec ($filespec)")
endif
$filespec=*get_output_file($query,"$drive$subdir","",$ext,$topic,#size)
endif
return $filespec
endfunc
proc mount_program($filespec,$topic)
mount_file__($filespec,1,$topic)
endproc
proc mount_file__($filespec,#is_prog,$topic)
declare $path,#nullfile,#reopen_help,$program
if (#is_prog)
$path=$dospath__
$program=program$blank
endif
#nullfile = -2
loop while (not *existf($filespec))
t:
if (#nullfile < -1)
t:*chr(7)\
#nullfile = *open("nul")
close #nullfile
if (#nullfile > 1 or (#nullfile > 0 and #help__ == -1))
t:   This program needs to change disks so that the $filespec
t:   $program\file is accessible, but it is not safe to do so because
t:   one or more files are open.
t:
if ($topic <> "")
explain($topic)
else
t:   The program must terminate immediately.  Please report this
t:   message to the program's author.
endif
foot
bye
endif
endif
t:   This program needs access to the $program\file $filespec.
t:   If you can change disks without removing any of your data files, please
t:   do so now.  Otherwise, exit by typing Ctrl-C and rearrange your disks
t:   so $filespec is available when this program is run.
t:
if (#help__ >= 0)
close #help__
#help__ = -1
#reopen_help = 1
endif
kbflush()
foot Press ENTER when you have changed disks.
endloop
if (#reopen_help)
reopen_help__()
endif
endproc
proc mount_file($filespec,$topic)
mount_file__($filespec,0,$topic)
endproc
proc reopen_help__()
if (*existf($helpfile__))
#help__ = *open($helpfile__)
else
t:*chr(7)
t:The help-file for this program was on the disk you removed.  You have
t:successfully changed disks, and the program should operate properly.
t:However, help information will no longer be available when you type '?'.
t:
$helpfile__=
kbflush()
foot
endif
endproc
.define .BELL t:*chr(7)\
.define .YES 1
.define .NO 0
.define .NOTFOUND 0
.define .READWRITE 2
.define .READONLY 4
.define .MININT (-2147483639)
.define .MAXINT   2147483639
.define .MAXCODE 78
.define .FILECHARS a-z0-9_A-Z!@#$%^&()'`{}~\-
.define .LOCALMATCH declare $left,$match,$right