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 >
Text File  |  1998-02-24  |  27KB  |  619 lines
  1. /******************************************************************************
  2.  * ISPF Prefix commands                                                       *
  3.  *                                                                            *
  4.  * Arguments:  cmd  - prefix command to be executed.  This may be any of the  *
  5.  *                    following:  add                                         *
  6.  *                                delete                                      *
  7.  *                                target                                      *
  8.  *                                show                                        *
  9.  *                                exclude                                     *
  10.  *                                shift                                       *
  11.  *                                duplicate                                   *
  12.  *                                current                                     *
  13.  *                                case                                        *
  14.  *                                                                            *
  15.  *             parm - command specific parameters                             *
  16.  *                                                                            *
  17.  *****************************************************************************/
  18. arg cmd parm
  19.  
  20. markno = 0                             /* global mark count */
  21. 'extract prefixentry'                  /* get text in prefix entry field */
  22. parse upper var prefixentry pe         /* uppercase text */
  23. count = getcount(pe)                   /* pull out numeric part of command */
  24.  
  25. select
  26.    /* Add command.  This command inserts one or more lines into the file.
  27.       Parameters: none */
  28.    when "ADD" = cmd then do
  29.  
  30.       'set prefixentry'                /* reset prefix entry field */
  31.       'extract class'                  /* get the class of this line */
  32.       if pos("PFXSHOW",class) \= 0 then do
  33.                                        /* this is an exclude header */
  34.          if nextline("next visible") then
  35.                                        /* move to next visible line */
  36.             'prev class PFXEXCLUDE'    /* find previous exclude line */
  37.          else do                       /* no more visible lines */
  38.             do forever                 /* loop through file */
  39.                if \nextline() then     /* if at end of file */
  40.                   leave                /* get out of loop */
  41.                'extract class'         /* get class of line */
  42.                if pos("PFXEXCLUDE",class) = 0 then do
  43.                                        /* if not exclude line */
  44.                   'prev'               /* go back one */
  45.                   leave                /* get out of loop */
  46.                end
  47.             end
  48.          end
  49.       end
  50.       'add 'count                      /* insert count lines */
  51.       exit                             /* done */
  52.    end
  53.  
  54.    /* Target command.  This command executes a block copy or move.
  55.       Parameters: before | after | overlay [block] */
  56.    when "TARGET" = cmd then do
  57.       parse var parm target block
  58.  
  59.       call setmark                     /* set a mark */
  60.  
  61.       if "BLOCK" = block then do
  62.          if \nextline() | findprefix(substr(pe,1,2)) = "" then
  63.             call errormsg(2 pe)
  64.          call setmark                  /* mark end of block */
  65.       end
  66.  
  67.       'top'                            /* go to top of file */
  68.       src = findprefix("C M")          /* search for copy or move */
  69.       if src = "" then                 /* if not found issue error */
  70.          call errormsg(1 pe)
  71.       'block clear'                    /* clear current block */
  72.       'block mark element'             /* mark the current element */
  73.       c1 = substr(src,1,1)             /* get first char of copy or move */
  74.       if c1 = "C" then call setmark    /* if copy, set another mark */
  75.       if c1 = substr(src,2,1) then do  /* if block copy or move... */
  76.          if \nextline() |,
  77.             findprefix(substr(src,1,2)) = "" then call errormsg(2 src)
  78.                                        /* find matching block */
  79.          'block mark element'          /* mark block */
  80.          if c1 = "C" then call setmark /* if copy, set another mark */
  81.       end
  82.       if c1 = "C" then                 /* set type of block operation */
  83.          action = "COPY"
  84.       else
  85.          action = "MOVE"
  86.  
  87.       'mark find PFXMARK1'             /* locate target */
  88.       if target = "OVERLAY" then
  89.          'block overlay transparent clear'
  90.       else
  91.          'block 'action target' clear' /* issue copy or move */
  92.       if RC = -3 then                  /* if copy/move into itself, error */
  93.          call errormsg(6 action)
  94.  
  95.    end
  96.  
  97.    /* Delete command.  This command deletes one or more lines.
  98.       Parameters:  [block] - indicate block delete */
  99.    when "DELETE" = cmd then do
  100.       'block clear'                    /* clear the current block */
  101.       'block mark element'             /* mark this element */
  102.       if parm = "BLOCK" then do        /* if block delete... */
  103.          if \nextline() | findprefix("DD") = "" then call errormsg(2 pe)
  104.                                        /* look for end of block */
  105.       end
  106.       else do                          /* else not block delete */
  107.          lines = count - 1
  108.          if lines > 0 then
  109.             'scroll down' lines        /* find last line to be deleted */
  110.       end
  111.       'extract class'                  /* get the class of the last line */
  112.       if pos("PFXSHOW",class) \= 0 then do
  113.                                        /* this is an exclude header */
  114.          if nextline("next visible") then
  115.                                        /* move to next visible line */
  116.             'prev class PFXEXCLUDE'    /* find previous exclude line */
  117.          else do                       /* no more visible lines */
  118.             do forever                 /* loop through file */
  119.                if \nextline() then     /* if at end of file */
  120.                   leave                /* get out of loop */
  121.                'extract class'         /* get class of line */
  122.                if pos("PFXEXCLUDE",class) = 0 then do
  123.                                        /* if not exclude line */
  124.                   'prev'               /* go back one */
  125.                   leave                /* get out of loop */
  126.                end
  127.             end
  128.          end
  129.       end
  130.       'extract deleting'               /* get deleting command */
  131.       'set deleting'                   /* remove it */
  132.       'block mark element'             /* mark the delete block */
  133.       'block delete'                   /* delete the block */
  134.       if headers() then                /* if there are still header lines */
  135.          'set deleting' deleting       /* restore deleting command */
  136.       exit                             /* all done */
  137.    end
  138.  
  139.    /* Show command.  This command shows one or more excluded lines.
  140.       Parameters: all | first | last - indicates which part of the excluded
  141.                                        block to show. */
  142.    when "SHOW" = cmd then do
  143.       'extract class'                  /* get class of current line */
  144.       if pos("PFXSHOW",class) == 0 then
  145.          call errormsg(3)              /* issue error if not exclude header */
  146.       call setmark                     /* set a mark on this line */
  147.       'set prefixentry'                /* clear the prefix entry text */
  148.  
  149.       if parm = "LAST" then do         /* if show last command */
  150.          do forever                    /* look for end of block */
  151.             if \nextline() then leave  /* if no more lines, leave */
  152.             'extract class'            /* get class of line */
  153.             if pos("PFXEXCLUDE",class) = 0 then do
  154.                                        /* if not part of block, leave */
  155.                'prev'
  156.                leave
  157.             end
  158.          end
  159.          dir = 'prev'                  /* set direction */
  160.       end
  161.       else do
  162.          dir = 'next'                  /* set direction */
  163.          'next'
  164.       end
  165.  
  166.       if parm = "ALL" then             /* if showing whole block */
  167.          'extract elements into count' /* set count to file size */
  168.  
  169.       do i = 1 to count                /* loop through the lines */
  170.          'extract class'               /* get class of line */
  171.          if pos("PFXEXCLUDE",class) == 0 then leave
  172.                                        /* if not an excluded line, leave */
  173.          parse var class pre "PFXEXCLUDE" post
  174.          'set class 'pre post          /* remove PFXEXCLUDE from class */
  175.          if \nextline(dir) then leave  /* if no more lines, leave */
  176.       end
  177.  
  178.       if "FIRST" = parm then do        /* if show fisrt command */
  179.          call beginchange              /* make sure changes not recorded */
  180.          'prev'                        /* back up a line */
  181.          'add'                         /* add a new exclude header */
  182.          'set class PFXSHOW'           /* set exclude header class */
  183.          'set show on'                 /* make it a show line */
  184.          call setmark                  /* mark this line */
  185.          'mark find PFXMARK1'          /* find old header */
  186.          call deleteheader             /* delete the header */
  187.          'mark find PFXMARK2'          /* find new header */
  188.          'mark clear PFXMARK2'         /* change mark name to PFXMARK1 */
  189.          markno = 0
  190.          call setmark
  191.          call endchange                /* restore recording status */
  192.       end
  193.       else                             /* not a show first */
  194.          'mark find PFXMARK1'          /* find header */
  195.  
  196.       call excludeheader               /* set exclude header text */
  197.    end
  198.  
  199.    /* Exclude command.  This command excludes one or more lines.
  200.       Parameters - [ALL | BLOCK] - indicates exclude all or block exclude */
  201.    when "EXCLUDE" = cmd then do
  202.       'extract classes'                /* Add PFXEXCLUDE and PFXSHOW classes */
  203.       if pos("PFXEXCLUDE",classes) = 0 then
  204.          'set classes 'classes' PFXSHOW PFXEXCLUDE'
  205.       'extract highlight'              /* Add PFXSHOW to highlight classes */
  206.       if pos("PFXSHOW",highlight) = 0 then
  207.          'set highlight 'highlight' PFXSHOW'
  208.       'extract exclude'                /* Add PFXEXCLUDE to exclude classes */
  209.       if pos("PFXEXCLUDE",exclude) = 0 then
  210.          'set exclude 'exclude' PFXEXCLUDE'
  211.       'extract protect'                /* Add PFXSHOW to protect classes */
  212.       if pos("PFXSHOW",protect) = 0 then
  213.          'set protect 'protect' PFXSHOW'
  214.  
  215.       'extract class'                  /* get class of current line */
  216.       if pos("PFXEXCLUDE",class) > 0 then do
  217.          'set prefixentry'             /* clear prefix entry field */
  218.          exit                          /* quit if line already hidden */
  219.       end
  220.  
  221.       call setmark                     /* set a mark */
  222.       'extract element into startline' /* get element number */
  223.  
  224.       if parm = "BLOCK" then do        /* if block exclude... */
  225.          if \nextline() |,
  226.             findprefix(substr(pe,1,2)) = "" then call errormsg(2 pe)
  227.                                        /* if block not found issue error */
  228.          'set prefixentry'             /* clear prefix entry field text */
  229.          'extract element into endline'/* get element number of end of block */
  230.          count = endline - startline + 1
  231.                                        /* calculate number of lines to exclude*/
  232.       end
  233.       else if parm = "ALL" then        /* if excluding all the lines */
  234.          'extract elements into count' /* get file size */
  235.  
  236.       call beginchange                 /* make sure changes not recorded */
  237.       'mark find PFXMARK1'             /* find first line to exclude */
  238.       'splitjoin split'                /* open a new line before it */
  239.       'set class PFXSHOW'              /* set exclude header class */
  240.       'set show on'                    /* make it a show line */
  241.       call endchange                   /* restore recording */
  242.  
  243.       'next'                           /* move to next line */
  244.       do i = 1 to count                /* loop through and exclude the lines */
  245.          'extract class'
  246.          if pos("PFXSHOW",class) > 0 then leave
  247.          'set class 'class' PFXEXCLUDE'
  248.          if \nextline() then leave
  249.       end
  250.  
  251.       call excludeheader               /* set exclude header */
  252.    end
  253.  
  254.    /* Shift command.  This command shifts one or more lines.
  255.       Parameters: right | left - indicates shift direction
  256.                   trunc | notrunc - indicates if shift should truncate line
  257.                   [block] - indicates block shift */
  258.    when "SHIFT" = cmd then do
  259.       parse var parm dir trunc type
  260.  
  261.       call setmark                     /* set a mark on this line */
  262.       'block clear'                    /* clear the current block */
  263.       'block mark element'             /* mark this line */
  264.  
  265.       if type = "BLOCK" then do        /* if block shift */
  266.          if \nextline() |,
  267.             findprefix(substr(pe,1,2)) = "" then call errormsg(2 pe)
  268.                                        /* search for end of block */
  269.          'set prefixentry'             /* clear prefix entry field text */
  270.          'block mark element'          /* mark the block */
  271.       end
  272.  
  273.       truncate = trunc \= "NOTRUNC"    /* set truncation flag */
  274.       if truncate then do              /* if truncate... */
  275.          'extract limiterror into savelimiterror'
  276.                                        /* save limiterror mode */
  277.          'set limiterror truncate'     /* set limiterror mode to truncate */
  278.          trunc = ""                    /* no option needed for turncate */
  279.       end
  280.  
  281.       'block shift 'dir count trunc' clear'
  282.                                        /* issue shift command */
  283.  
  284.       if truncate then                 /* if truncate, restore limiterror */
  285.          'set limiterror 'savelimiterror
  286.    end
  287.  
  288.    /* Duplicate command.  This command duplicates the current line one or more times
  289.       Parameters:  none */
  290.    when "DUPLICATE" = cmd then do
  291.       call setmark                     /* set a mark on this line */
  292.       'block clear'                    /* clear the current block */
  293.       'block mark element'             /* mark this line */
  294.  
  295.       if parm = "BLOCK" then do        /* if block repeat... */
  296.                                        /* look for end of block */
  297.          if \nextline() | findprefix(substr(pe,1,2)) = "" then
  298.             call errormsg(2 pe)
  299.          'set prefixentry'             /* clear prefix entry field */
  300.          'block mark element'          /* mark the block */
  301.       end
  302.  
  303.       do i = 1 to count                /* copy the line count times */
  304.          'block copy after'
  305.       end
  306.       'block clear'                    /* clear the block */
  307.    end
  308.  
  309.    /* Current command.  This command sets the current line.
  310.       Parameters:  none */
  311.    when "CURRENT" = cmd then do
  312.       call setmark                     /* set a mark on this line */
  313.  
  314.       'set focus.next 1'               /* set to top of window */
  315.       'mark find PFXMARK1'             /* make this the current line */
  316.    end
  317.  
  318.    /* Case command.  This command changes the case of the specified line
  319.       Parameters: upper [block]| lower [block] - indicates desired case */
  320.    when "CASE" = cmd then do
  321.       parse var parm case block
  322.       'set prefixentry'                /* clear prefix entry field */
  323.       'block clear'                    /* clear the current block */
  324.       'block mark element'             /* mark this line */
  325.       if block = "BLOCK" then do
  326.          if case = "UPPER" then do       /* look for block end */
  327.             if \nextline() | findprefix("UCC") = "" then call errormsg(2 pe)
  328.          end
  329.          else if case = "LOWER" then do       /* look for block end */
  330.             if \nextline() | findprefix("LCC") = "" then call errormsg(2 pe)
  331.          end
  332.       end
  333.       else do
  334.          extract element into start
  335.          end = start + count -1              /* get number of lines affected */
  336.          if end > start then
  337.             'find element' end           /* move to last line            */
  338.       end
  339.       'extract class'                  /* get the class of the last line */
  340.       if pos("PFXSHOW",class) \= 0 then do
  341.                                        /* this is an exclude header */
  342.          if nextline("next visible") then
  343.                                        /* move to next visible line */
  344.             'prev class PFXEXCLUDE'    /* find previous exclude line */
  345.          else do                       /* no more visible lines */
  346.             do forever                 /* loop through file */
  347.                if \nextline() then     /* if at end of file */
  348.                   leave                /* get out of loop */
  349.                'extract class'         /* get class of line */
  350.                if pos("PFXEXCLUDE",class) = 0 then do
  351.                                        /* if not exclude line */
  352.                   'prev'               /* go back one */
  353.                   leave                /* get out of loop */
  354.                end
  355.             end
  356.          end
  357.       end
  358.       'set prefixentry'                /* clear prefix entry field */
  359.       'block mark element'             /* mark the case block   */
  360.       'block 'case' clear'             /* set the case          */
  361.       exit
  362.    end
  363. end
  364.  
  365. call setmark                           /* save the current position */
  366. do i = 1 to (markno - 1)               /* loop through the marked lines */
  367.    'extract mark.PFXMARK'i' into markcol'
  368.    if markcol \= 0 then do             /* if mark not deleted */
  369.       'mark find PFXMARK'i             /* find the mark */
  370.       'set prefixentry'                /* clear the prefix entry field */
  371.    end
  372. end
  373. 'mark find PFXMARK'markno              /* restore the current position */
  374.  
  375. cleanup:
  376.  
  377. do i = 1 to markno                     /* loop through and delete marks */
  378.    'mark clear PFXMARK'i
  379. end
  380.  
  381. exit                                   /* all done */
  382.  
  383. /******************************************************************************
  384.  *                                                                            *
  385.  * function getcount(str)                                                     *
  386.  *                                                                            *
  387.  * This function returns the numeric part of a character string.  If there is *
  388.  * no numeric part, then 1 is returned.                                       *
  389.  *                                                                            *
  390.  ******************************************************************************/
  391. getcount:
  392.  
  393. procedure
  394.  
  395. arg count
  396.  
  397. do while datatype(substr(count,1,1)) \= "NUM"
  398.    if length(count) = 1 then
  399.       count = 1
  400.    else
  401.       count = substr(count,2)
  402. end
  403.  
  404. do while datatype(substr(count,length(count))) \= "NUM"
  405.    if length(count) = 1 then
  406.       count = 1
  407.    else
  408.       count = delstr(count,length(count))
  409. end
  410.  
  411. return abs(count)
  412.  
  413. /******************************************************************************
  414.  *                                                                            *
  415.  * setmark routine                                                            *
  416.  *                                                                            *
  417.  * This routine sets a mark on the current line.  It uses the global variable *
  418.  * markno to give the mark a unique name.                                     *
  419.  *                                                                            *
  420.  ******************************************************************************/
  421. setmark:
  422.  
  423. procedure expose markno
  424.  
  425. markno = markno + 1
  426. 'extract element into e'
  427. 'mark set PFXMARK'markno e '-1'
  428. return
  429.  
  430. /******************************************************************************
  431.  *                                                                            *
  432.  * function findprefix(str)                                                   *
  433.  *                                                                            *
  434.  * This function looks for a line whose prefix entry field contains text that *
  435.  * begins with str.  If str contains more than one string, then the first     *
  436.  * line that matches either is returned.  The actual prefix text is returned  *
  437.  * by this function.                                                          *
  438.  *                                                                            *
  439.  ******************************************************************************/
  440. findprefix:
  441.  
  442. procedure
  443.  
  444. arg parm
  445.  
  446. do forever
  447.    'extract prefixentry into pe'
  448.    parse upper var pe upperpe
  449.    cmds = parm
  450.    do while length(cmds) > 0
  451.       parse var cmds cmd cmds
  452.       if length(upperpe) >= length(cmd) then
  453.          if cmd = substr(upperpe,1,length(cmd)) then
  454.             return upperpe
  455.    end
  456.    'find prefixentry'
  457.    if RC \= 0 then return ""
  458. end
  459.  
  460. /******************************************************************************
  461.  *                                                                            *
  462.  * beginchange routine                                                        *
  463.  *                                                                            *
  464.  * This routine changes the recording state so that changes will not be       *
  465.  * recorded.                                                                  *
  466.  *                                                                            *
  467.  ******************************************************************************/
  468. beginchange:
  469.  
  470. procedure expose savechanges saverecording
  471.  
  472. 'extract changes into savechanges'
  473. 'extract recording into saverecording'
  474.  
  475. 'set recording off'
  476. return
  477.  
  478. /******************************************************************************
  479.  *                                                                            *
  480.  * endchange routine                                                          *
  481.  *                                                                            *
  482.  * This routine restored the recording state to that before beginchange was   *
  483.  * called.                                                                    *
  484.  *                                                                            *
  485.  ******************************************************************************/
  486. endchange:
  487.  
  488. procedure expose saverecording savechanges
  489.  
  490. 'set recording 'saverecording
  491. 'set changes 'savechanges
  492. return
  493.  
  494. /******************************************************************************
  495.  *                                                                            *
  496.  * excludeheader routine                                                      *
  497.  *                                                                            *
  498.  * This routine counts the number of excluded line is a block and sets the    *
  499.  * exclude header text appropriately.                                         *
  500.  *                                                                            *
  501.  ******************************************************************************/
  502. excludeheader:
  503.  
  504. procedure
  505.  
  506. 'mark find PFXMARK1'
  507. lines = 0
  508. do forever
  509.    if \nextline() then leave
  510.    'extract class'
  511.    if pos("PFXEXCLUDE",class) == 0 then leave
  512.    lines = lines + 1
  513. end
  514.  
  515. call beginchange
  516. 'mark find PFXMARK1'
  517. if 0 = lines then do
  518.    call deleteheader
  519.    call endchange
  520.    exit
  521. end
  522. 'extract limiterror into savelimiterror'
  523. 'set limiterror ignore'
  524. if 1 = lines then
  525.    'set content 'ispfmsg(4)
  526. else
  527.    'set content 'ispfmsg(5 lines)
  528. 'set limiterror 'savelimiterror
  529. call endchange
  530.  
  531. 'extract deleting'
  532. if deleting = "" then do
  533.    'macroload pfxdel.lx'
  534.    'set deleting pfxdel'
  535. end
  536.  
  537. return
  538.  
  539. /******************************************************************************
  540.  *                                                                            *
  541.  * deleteheader routine                                                       *
  542.  *                                                                            *
  543.  * This routine deletes the current exclude header line.                      *
  544.  *                                                                            *
  545.  ******************************************************************************/
  546. deleteheader:
  547.  
  548. procedure
  549.  
  550. 'extract deleting'
  551. 'set deleting'
  552. 'delete'
  553. if headers() then
  554.    'set deleting 'deleting
  555.  
  556. return
  557.  
  558. /******************************************************************************
  559.  *                                                                            *
  560.  * function headers()                                                         *
  561.  *                                                                            *
  562.  * This function returns TRUE if there are any headers remaining.             *
  563.  *                                                                            *
  564.  ******************************************************************************/
  565. headers:
  566.  
  567. procedure
  568.  
  569. 'extract classes'
  570. if (pos("PFXSHOW",classes) = 0) then
  571.    return 0
  572.  
  573. 'extract element into e'
  574. 'mark set PFXMARKH' e '-1'
  575. 'top'
  576. 'next class PFXSHOW'
  577. 'extract class'
  578. 'mark find PFXMARKH'
  579. 'mark clear PFXMARKH'
  580.  
  581. return (pos("PFXSHOW",class) \= 0)
  582.  
  583. /******************************************************************************
  584.  *                                                                            *
  585.  * function nextline(dir)                                                     *
  586.  *                                                                            *
  587.  * This function accepts a direction (prev or next) and move to the previous  *
  588.  * or next line.  It returns TRUE if the operation completed successfully.    *
  589.  *                                                                            *
  590.  ******************************************************************************/
  591. nextline:
  592.  
  593. procedure
  594.  
  595. arg dir parm
  596.  
  597. if dir \= "PREV" then
  598.    dir = 'next'
  599.  
  600. 'extract element into preve'
  601. dir parm
  602. 'extract element'
  603. return element \= preve
  604.  
  605. /******************************************************************************
  606.  *                                                                            *
  607.  * errormsg(msgno insert) routine                                             *
  608.  *                                                                            *
  609.  * This routine issues an error message msgno and exits.                      *
  610.  *                                                                            *
  611.  ******************************************************************************/
  612. errormsg:
  613.  
  614. arg msgno insert
  615.  
  616. 'msg 'ispfmsg(msgno insert)
  617. signal cleanup
  618.  
  619.