1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1990   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(90-03-21,Vu), approve(90-03-21,MCR8165), audit(90-03-29,Zimmerman),
 17      install(90-04-19,MR12.4-1006):
 18      Fix -bf argument for terminate_refname.
 19                                                    END HISTORY COMMENTS */
 20 
 21 
 22 terminate: tm: proc;
 23 
 24 /* Implements the terminate commands:
 25 
 26           terminate paths {-control_args}
 27 
 28           terminate_segno segment_numbers {-control_args}
 29 
 30           terminate_refname reference_names {-control_args}
 31 
 32           terminate_single_refname reference_names {-control_args}
 33 
 34 The first three terminate segments; the last terminates only specified refnames.
 35 Rewritten 01/11/80 by S. Herbst */
 36 /* Changed to not abort for error_table_$seg_unknown 03/04/81 S. Herbst */
 37 
 38 
 39 dcl arg char (arg_len) based (arg_ptr);
 40 dcl dn char (168);
 41 dcl (en, myname, refname, usage) char (32);
 42 
 43 dcl (brief_sw, some_args) bit (1);
 44 
 45 dcl (arg_ptr, seg_ptr) ptr;
 46 
 47 dcl (arg_count, arg_len, i, segno) fixed bin;
 48 dcl code fixed bin (35);
 49 
 50 dcl error_table_$badopt fixed bin (35) ext;
 51 dcl error_table_$invalidsegno fixed bin (35) ext;
 52 dcl error_table_$name_not_found fixed bin (35) ext;
 53 dcl error_table_$seg_unknown fixed bin (35) ext;
 54 
 55 dcl active_fnc_err_ entry options (variable);
 56 dcl (com_err_, com_err_$suppress_name) entry options (variable);
 57 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
 58 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 59 dcl cv_oct_check_ entry (char (*), fixed bin (35)) returns (fixed bin);
 60 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 61 dcl get_wdir_ entry returns (char (168));
 62 dcl term_ entry (char (*), char (*), fixed bin (35));
 63 dcl term_$refname entry (char (*), fixed bin (35));
 64 dcl term_$seg_ptr entry (ptr, fixed bin (35));
 65 dcl term_$single_refname entry (char (*), fixed bin (35));
 66 
 67 dcl (baseptr, null, substr) builtin;
 68 /*^L*/
 69           myname = "terminate";
 70           usage = "paths";
 71           go to COMMON;
 72 
 73 terminate_segno: tms: entry;
 74 
 75           myname = "terminate_segno";
 76           usage = "segment_numbers";
 77           go to COMMON;
 78 
 79 terminate_refname: tmr: entry;
 80 
 81           myname = "terminate_refname";
 82           usage = "reference_names";
 83           go to COMMON;
 84 
 85 terminate_single_refname: tmsr: entry;
 86 
 87           myname = "terminate_single_refname";
 88           usage = "reference_names";
 89 
 90 
 91 COMMON:   call cu_$af_return_arg (arg_count, null, 0, code);
 92           if code = 0 then do;
 93                call active_fnc_err_ (0, myname, "Cannot be called as an active function.");
 94                return;
 95           end;
 96 
 97           brief_sw, some_args = "0"b;
 98           do i = 1 to arg_count;
 99 
100                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
101 
102                if substr (arg, 1, 1) ^= "-" then some_args = "1"b;
103 
104                else if arg = "-brief" | arg = "-bf" then brief_sw = "1"b;
105                else if arg = "-long" | arg = "-lg" then brief_sw = "0"b;
106                else if arg = "-name" | arg = "-nm" then do;
107                     i = i + 1;
108                     if i > arg_count then do;
109                          call com_err_ (0, myname, "No value specified for -name");
110                          return;
111                     end;
112                     some_args = "1"b;
113                end;
114                else do;
115                     call com_err_ (error_table_$badopt, myname, "^a", arg);
116                     return;
117                end;
118           end;
119 
120           if ^some_args then do;
121                call com_err_$suppress_name (0, myname, "Usage:  ^a ^a {-control_args}", myname, usage);
122                return;
123           end;
124 
125           do i = 1 to arg_count;
126 
127                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
128 
129                if substr (arg, 1, 1) ^= "-" then do;
130 
131 TERMINATE:          if myname = "terminate" then do;
132                          call expand_pathname_ (arg, dn, en, code);
133                          if code ^= 0 then do;
134                               call com_err_ (code, myname, "^a", arg);
135                               return;
136                          end;
137 TERM_PATH:               call term_ (dn, en, code);
138                          if code ^= 0 then do;
139                               if ^brief_sw | code ^= error_table_$seg_unknown then
140                                    call com_err_ (code, myname, "^a^[>^]^a", dn, dn ^= ">", en);
141                               if code ^= error_table_$seg_unknown then return;
142                          end;
143                     end;
144                     else if myname = "terminate_segno" then do;
145                          segno = cv_oct_check_ (arg, code);
146                          if code ^= 0 then do;
147                               call com_err_ (0, myname, "Invalid octal number ^a", arg);
148                               return;
149                          end;
150                          seg_ptr = baseptr (segno);
151                          call term_$seg_ptr (seg_ptr, code);
152                          if code ^= 0 then do;
153                               if ^brief_sw | (code ^= error_table_$seg_unknown & code ^= error_table_$invalidsegno) then
154                                    call com_err_ (code, myname, "^a", arg);
155                               if code ^= error_table_$seg_unknown then return;
156                          end;
157                     end;
158                     else if myname = "terminate_refname" then do;
159                          refname = arg;
160                          call term_$refname (refname, code);
161                          if code ^= 0 then do;
162 TERM_ERROR:                   if ^brief_sw | (code ^= error_table_$seg_unknown & code ^= error_table_$name_not_found) then
163                                    call com_err_ (code, myname, "^a", arg);
164                               if code ^= error_table_$seg_unknown then return;
165                          end;
166                     end;
167                     else do;                                /* terminate_single_refname */
168                          refname = arg;
169                          call term_$single_refname (refname, code);
170                          if code ^= 0 then go to TERM_ERROR;
171                     end;
172                end;
173                else if arg = "-name" | arg = "-nm" then do;
174                     i = i + 1;
175                     call cu_$arg_ptr (i, arg_ptr, arg_len, code);
176                     if myname = "terminate" then do;        /* pathname */
177                          dn = get_wdir_ ();
178                          en = arg;
179                          go to TERM_PATH;
180                     end;
181                     else go to TERMINATE;
182                end;
183           end;
184 
185 end terminate;