home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
viscobv7.zip
/
vac22os2
/
ibmcobol
/
macros
/
ispfcmd.lx
< prev
next >
Wrap
Text File
|
1998-02-24
|
27KB
|
619 lines
/******************************************************************************
* ISPF Prefix commands *
* *
* Arguments: cmd - prefix command to be executed. This may be any of the *
* following: add *
* delete *
* target *
* show *
* exclude *
* shift *
* duplicate *
* current *
* case *
* *
* parm - command specific parameters *
* *
*****************************************************************************/
arg cmd parm
markno = 0 /* global mark count */
'extract prefixentry' /* get text in prefix entry field */
parse upper var prefixentry pe /* uppercase text */
count = getcount(pe) /* pull out numeric part of command */
select
/* Add command. This command inserts one or more lines into the file.
Parameters: none */
when "ADD" = cmd then do
'set prefixentry' /* reset prefix entry field */
'extract class' /* get the class of this line */
if pos("PFXSHOW",class) \= 0 then do
/* this is an exclude header */
if nextline("next visible") then
/* move to next visible line */
'prev class PFXEXCLUDE' /* find previous exclude line */
else do /* no more visible lines */
do forever /* loop through file */
if \nextline() then /* if at end of file */
leave /* get out of loop */
'extract class' /* get class of line */
if pos("PFXEXCLUDE",class) = 0 then do
/* if not exclude line */
'prev' /* go back one */
leave /* get out of loop */
end
end
end
end
'add 'count /* insert count lines */
exit /* done */
end
/* Target command. This command executes a block copy or move.
Parameters: before | after | overlay [block] */
when "TARGET" = cmd then do
parse var parm target block
call setmark /* set a mark */
if "BLOCK" = block then do
if \nextline() | findprefix(substr(pe,1,2)) = "" then
call errormsg(2 pe)
call setmark /* mark end of block */
end
'top' /* go to top of file */
src = findprefix("C M") /* search for copy or move */
if src = "" then /* if not found issue error */
call errormsg(1 pe)
'block clear' /* clear current block */
'block mark element' /* mark the current element */
c1 = substr(src,1,1) /* get first char of copy or move */
if c1 = "C" then call setmark /* if copy, set another mark */
if c1 = substr(src,2,1) then do /* if block copy or move... */
if \nextline() |,
findprefix(substr(src,1,2)) = "" then call errormsg(2 src)
/* find matching block */
'block mark element' /* mark block */
if c1 = "C" then call setmark /* if copy, set another mark */
end
if c1 = "C" then /* set type of block operation */
action = "COPY"
else
action = "MOVE"
'mark find PFXMARK1' /* locate target */
if target = "OVERLAY" then
'block overlay transparent clear'
else
'block 'action target' clear' /* issue copy or move */
if RC = -3 then /* if copy/move into itself, error */
call errormsg(6 action)
end
/* Delete command. This command deletes one or more lines.
Parameters: [block] - indicate block delete */
when "DELETE" = cmd then do
'block clear' /* clear the current block */
'block mark element' /* mark this element */
if parm = "BLOCK" then do /* if block delete... */
if \nextline() | findprefix("DD") = "" then call errormsg(2 pe)
/* look for end of block */
end
else do /* else not block delete */
lines = count - 1
if lines > 0 then
'scroll down' lines /* find last line to be deleted */
end
'extract class' /* get the class of the last line */
if pos("PFXSHOW",class) \= 0 then do
/* this is an exclude header */
if nextline("next visible") then
/* move to next visible line */
'prev class PFXEXCLUDE' /* find previous exclude line */
else do /* no more visible lines */
do forever /* loop through file */
if \nextline() then /* if at end of file */
leave /* get out of loop */
'extract class' /* get class of line */
if pos("PFXEXCLUDE",class) = 0 then do
/* if not exclude line */
'prev' /* go back one */
leave /* get out of loop */
end
end
end
end
'extract deleting' /* get deleting command */
'set deleting' /* remove it */
'block mark element' /* mark the delete block */
'block delete' /* delete the block */
if headers() then /* if there are still header lines */
'set deleting' deleting /* restore deleting command */
exit /* all done */
end
/* Show command. This command shows one or more excluded lines.
Parameters: all | first | last - indicates which part of the excluded
block to show. */
when "SHOW" = cmd then do
'extract class' /* get class of current line */
if pos("PFXSHOW",class) == 0 then
call errormsg(3) /* issue error if not exclude header */
call setmark /* set a mark on this line */
'set prefixentry' /* clear the prefix entry text */
if parm = "LAST" then do /* if show last command */
do forever /* look for end of block */
if \nextline() then leave /* if no more lines, leave */
'extract class' /* get class of line */
if pos("PFXEXCLUDE",class) = 0 then do
/* if not part of block, leave */
'prev'
leave
end
end
dir = 'prev' /* set direction */
end
else do
dir = 'next' /* set direction */
'next'
end
if parm = "ALL" then /* if showing whole block */
'extract elements into count' /* set count to file size */
do i = 1 to count /* loop through the lines */
'extract class' /* get class of line */
if pos("PFXEXCLUDE",class) == 0 then leave
/* if not an excluded line, leave */
parse var class pre "PFXEXCLUDE" post
'set class 'pre post /* remove PFXEXCLUDE from class */
if \nextline(dir) then leave /* if no more lines, leave */
end
if "FIRST" = parm then do /* if show fisrt command */
call beginchange /* make sure changes not recorded */
'prev' /* back up a line */
'add' /* add a new exclude header */
'set class PFXSHOW' /* set exclude header class */
'set show on' /* make it a show line */
call setmark /* mark this line */
'mark find PFXMARK1' /* find old header */
call deleteheader /* delete the header */
'mark find PFXMARK2' /* find new header */
'mark clear PFXMARK2' /* change mark name to PFXMARK1 */
markno = 0
call setmark
call endchange /* restore recording status */
end
else /* not a show first */
'mark find PFXMARK1' /* find header */
call excludeheader /* set exclude header text */
end
/* Exclude command. This command excludes one or more lines.
Parameters - [ALL | BLOCK] - indicates exclude all or block exclude */
when "EXCLUDE" = cmd then do
'extract classes' /* Add PFXEXCLUDE and PFXSHOW classes */
if pos("PFXEXCLUDE",classes) = 0 then
'set classes 'classes' PFXSHOW PFXEXCLUDE'
'extract highlight' /* Add PFXSHOW to highlight classes */
if pos("PFXSHOW",highlight) = 0 then
'set highlight 'highlight' PFXSHOW'
'extract exclude' /* Add PFXEXCLUDE to exclude classes */
if pos("PFXEXCLUDE",exclude) = 0 then
'set exclude 'exclude' PFXEXCLUDE'
'extract protect' /* Add PFXSHOW to protect classes */
if pos("PFXSHOW",protect) = 0 then
'set protect 'protect' PFXSHOW'
'extract class' /* get class of current line */
if pos("PFXEXCLUDE",class) > 0 then do
'set prefixentry' /* clear prefix entry field */
exit /* quit if line already hidden */
end
call setmark /* set a mark */
'extract element into startline' /* get element number */
if parm = "BLOCK" then do /* if block exclude... */
if \nextline() |,
findprefix(substr(pe,1,2)) = "" then call errormsg(2 pe)
/* if block not found issue error */
'set prefixentry' /* clear prefix entry field text */
'extract element into endline'/* get element number of end of block */
count = endline - startline + 1
/* calculate number of lines to exclude*/
end
else if parm = "ALL" then /* if excluding all the lines */
'extract elements into count' /* get file size */
call beginchange /* make sure changes not recorded */
'mark find PFXMARK1' /* find first line to exclude */
'splitjoin split' /* open a new line before it */
'set class PFXSHOW' /* set exclude header class */
'set show on' /* make it a show line */
call endchange /* restore recording */
'next' /* move to next line */
do i = 1 to count /* loop through and exclude the lines */
'extract class'
if pos("PFXSHOW",class) > 0 then leave
'set class 'class' PFXEXCLUDE'
if \nextline() then leave
end
call excludeheader /* set exclude header */
end
/* Shift command. This command shifts one or more lines.
Parameters: right | left - indicates shift direction
trunc | notrunc - indicates if shift should truncate line
[block] - indicates block shift */
when "SHIFT" = cmd then do
parse var parm dir trunc type
call setmark /* set a mark on this line */
'block clear' /* clear the current block */
'block mark element' /* mark this line */
if type = "BLOCK" then do /* if block shift */
if \nextline() |,
findprefix(substr(pe,1,2)) = "" then call errormsg(2 pe)
/* search for end of block */
'set prefixentry' /* clear prefix entry field text */
'block mark element' /* mark the block */
end
truncate = trunc \= "NOTRUNC" /* set truncation flag */
if truncate then do /* if truncate... */
'extract limiterror into savelimiterror'
/* save limiterror mode */
'set limiterror truncate' /* set limiterror mode to truncate */
trunc = "" /* no option needed for turncate */
end
'block shift 'dir count trunc' clear'
/* issue shift command */
if truncate then /* if truncate, restore limiterror */
'set limiterror 'savelimiterror
end
/* Duplicate command. This command duplicates the current line one or more times
Parameters: none */
when "DUPLICATE" = cmd then do
call setmark /* set a mark on this line */
'block clear' /* clear the current block */
'block mark element' /* mark this line */
if parm = "BLOCK" then do /* if block repeat... */
/* look for end of block */
if \nextline() | findprefix(substr(pe,1,2)) = "" then
call errormsg(2 pe)
'set prefixentry' /* clear prefix entry field */
'block mark element' /* mark the block */
end
do i = 1 to count /* copy the line count times */
'block copy after'
end
'block clear' /* clear the block */
end
/* Current command. This command sets the current line.
Parameters: none */
when "CURRENT" = cmd then do
call setmark /* set a mark on this line */
'set focus.next 1' /* set to top of window */
'mark find PFXMARK1' /* make this the current line */
end
/* Case command. This command changes the case of the specified line
Parameters: upper [block]| lower [block] - indicates desired case */
when "CASE" = cmd then do
parse var parm case block
'set prefixentry' /* clear prefix entry field */
'block clear' /* clear the current block */
'block mark element' /* mark this line */
if block = "BLOCK" then do
if case = "UPPER" then do /* look for block end */
if \nextline() | findprefix("UCC") = "" then call errormsg(2 pe)
end
else if case = "LOWER" then do /* look for block end */
if \nextline() | findprefix("LCC") = "" then call errormsg(2 pe)
end
end
else do
extract element into start
end = start + count -1 /* get number of lines affected */
if end > start then
'find element' end /* move to last line */
end
'extract class' /* get the class of the last line */
if pos("PFXSHOW",class) \= 0 then do
/* this is an exclude header */
if nextline("next visible") then
/* move to next visible line */
'prev class PFXEXCLUDE' /* find previous exclude line */
else do /* no more visible lines */
do forever /* loop through file */
if \nextline() then /* if at end of file */
leave /* get out of loop */
'extract class' /* get class of line */
if pos("PFXEXCLUDE",class) = 0 then do
/* if not exclude line */
'prev' /* go back one */
leave /* get out of loop */
end
end
end
end
'set prefixentry' /* clear prefix entry field */
'block mark element' /* mark the case block */
'block 'case' clear' /* set the case */
exit
end
end
call setmark /* save the current position */
do i = 1 to (markno - 1) /* loop through the marked lines */
'extract mark.PFXMARK'i' into markcol'
if markcol \= 0 then do /* if mark not deleted */
'mark find PFXMARK'i /* find the mark */
'set prefixentry' /* clear the prefix entry field */
end
end
'mark find PFXMARK'markno /* restore the current position */
cleanup:
do i = 1 to markno /* loop through and delete marks */
'mark clear PFXMARK'i
end
exit /* all done */
/******************************************************************************
* *
* function getcount(str) *
* *
* This function returns the numeric part of a character string. If there is *
* no numeric part, then 1 is returned. *
* *
******************************************************************************/
getcount:
procedure
arg count
do while datatype(substr(count,1,1)) \= "NUM"
if length(count) = 1 then
count = 1
else
count = substr(count,2)
end
do while datatype(substr(count,length(count))) \= "NUM"
if length(count) = 1 then
count = 1
else
count = delstr(count,length(count))
end
return abs(count)
/******************************************************************************
* *
* setmark routine *
* *
* This routine sets a mark on the current line. It uses the global variable *
* markno to give the mark a unique name. *
* *
******************************************************************************/
setmark:
procedure expose markno
markno = markno + 1
'extract element into e'
'mark set PFXMARK'markno e '-1'
return
/******************************************************************************
* *
* function findprefix(str) *
* *
* This function looks for a line whose prefix entry field contains text that *
* begins with str. If str contains more than one string, then the first *
* line that matches either is returned. The actual prefix text is returned *
* by this function. *
* *
******************************************************************************/
findprefix:
procedure
arg parm
do forever
'extract prefixentry into pe'
parse upper var pe upperpe
cmds = parm
do while length(cmds) > 0
parse var cmds cmd cmds
if length(upperpe) >= length(cmd) then
if cmd = substr(upperpe,1,length(cmd)) then
return upperpe
end
'find prefixentry'
if RC \= 0 then return ""
end
/******************************************************************************
* *
* beginchange routine *
* *
* This routine changes the recording state so that changes will not be *
* recorded. *
* *
******************************************************************************/
beginchange:
procedure expose savechanges saverecording
'extract changes into savechanges'
'extract recording into saverecording'
'set recording off'
return
/******************************************************************************
* *
* endchange routine *
* *
* This routine restored the recording state to that before beginchange was *
* called. *
* *
******************************************************************************/
endchange:
procedure expose saverecording savechanges
'set recording 'saverecording
'set changes 'savechanges
return
/******************************************************************************
* *
* excludeheader routine *
* *
* This routine counts the number of excluded line is a block and sets the *
* exclude header text appropriately. *
* *
******************************************************************************/
excludeheader:
procedure
'mark find PFXMARK1'
lines = 0
do forever
if \nextline() then leave
'extract class'
if pos("PFXEXCLUDE",class) == 0 then leave
lines = lines + 1
end
call beginchange
'mark find PFXMARK1'
if 0 = lines then do
call deleteheader
call endchange
exit
end
'extract limiterror into savelimiterror'
'set limiterror ignore'
if 1 = lines then
'set content 'ispfmsg(4)
else
'set content 'ispfmsg(5 lines)
'set limiterror 'savelimiterror
call endchange
'extract deleting'
if deleting = "" then do
'macroload pfxdel.lx'
'set deleting pfxdel'
end
return
/******************************************************************************
* *
* deleteheader routine *
* *
* This routine deletes the current exclude header line. *
* *
******************************************************************************/
deleteheader:
procedure
'extract deleting'
'set deleting'
'delete'
if headers() then
'set deleting 'deleting
return
/******************************************************************************
* *
* function headers() *
* *
* This function returns TRUE if there are any headers remaining. *
* *
******************************************************************************/
headers:
procedure
'extract classes'
if (pos("PFXSHOW",classes) = 0) then
return 0
'extract element into e'
'mark set PFXMARKH' e '-1'
'top'
'next class PFXSHOW'
'extract class'
'mark find PFXMARKH'
'mark clear PFXMARKH'
return (pos("PFXSHOW",class) \= 0)
/******************************************************************************
* *
* function nextline(dir) *
* *
* This function accepts a direction (prev or next) and move to the previous *
* or next line. It returns TRUE if the operation completed successfully. *
* *
******************************************************************************/
nextline:
procedure
arg dir parm
if dir \= "PREV" then
dir = 'next'
'extract element into preve'
dir parm
'extract element'
return element \= preve
/******************************************************************************
* *
* errormsg(msgno insert) routine *
* *
* This routine issues an error message msgno and exits. *
* *
******************************************************************************/
errormsg:
arg msgno insert
'msg 'ispfmsg(msgno insert)
signal cleanup