1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1983 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 /* format: off */
 10 
 11 /* Multics qedx Editor command interface */
 12 
 13 /* Created:  January 1983 by G. Palter as part of implementation of qedx_ subroutine interface */
 14 
 15 /* format: on,style4,delnl,insnl,ifthenstmt,ifthen */
 16 
 17 
 18 qedx:
 19 qx:
 20      procedure () options (variable);
 21 
 22 
 23 dcl  argument character (argument_lth) unaligned based (argument_ptr);
 24 dcl  argument_ptr pointer;
 25 dcl  argument_lth fixed binary (21);
 26 dcl  (n_arguments, argument_idx) fixed binary;
 27 
 28 dcl  input_dirname character (168);
 29 dcl  input_ename character (32);
 30 dcl  input_component character (32);
 31 dcl  input_file_ptr pointer;
 32 
 33 dcl  exec_dirname character (168);
 34 dcl  exec_ename character (32);
 35 dcl  exec_component character (32);
 36 dcl  exec_buffer_bc fixed binary (24);
 37 dcl  exec_buffer_ptr pointer;
 38 
 39 dcl  args_buffer character (4 * sys_info$max_seg_size) based (args_buffer_ptr);
 40 dcl  args_buffer_used fixed binary (21);
 41 dcl  args_buffer_ptr pointer;
 42 
 43 dcl  1 local_qi aligned,                                    /* describes how we want the invocation setup */
 44        2 header like qedx_info.header,
 45        2 buffers (3) like qedx_info.buffers;                /* 0, exec, args */
 46 
 47 dcl  ok_to_continue bit (1);                                /* command_query_$yes_no should have used aligned */
 48 
 49 dcl  (no_rw_path, have_pathname, have_macro_pathname, have_macro_arguments) bit (1) aligned;
 50 
 51 dcl  idx fixed binary;
 52 dcl  code fixed binary (35);
 53 
 54 dcl  invocation_level fixed binary static initial (0);      /* # of active invocations of qedx */
 55 
 56 dcl  NL character (1) static options (constant) initial ("
 57 ");
 58 
 59 dcl  QEDX character (32) static options (constant) initial ("qedx");
 60 
 61 dcl  1 RECURSION_EXPLANATION_SECTIONS aligned static options (constant),
 62        2 part1 character (200) unaligned
 63             initial ("There ^[are^;is^] ^d suspended invocation^[s^] of the qedx command which you have
 64 interrupted (eg: by a quit signal) that are still active.  If you
 65 answer ""yes"" to this query, you will have an additio"),
 66        2 part2 character (200) unaligned initial ("nal invocation of
 67 qedx.  Any changes that you have made to files in prior invocations
 68 which you have not yet written will not be available to this new qedx.
 69 In addition, any changes you make to files "),
 70        2 part3 character (200) unaligned initial ("in this qedx which you are
 71 also editing in prior invocations will not be reflected in those prior
 72 invocations and could be lost if you later write out the same file in
 73 one of those other invocations.
 74 "),
 75        2 part4 character (200) unaligned initial ("
 76 We suggest that you answer ""no"" to this query and use either the
 77 ""start"" or ""program_interrupt"" command to resume one of your previous
 78 invocations of qedx or that you use the ""release"" command to abo"),
 79        2 part5 character (200) unaligned initial ("rt
 80 those older invocations if you are certain there aren't any modified
 81 buffers in them.
 82 
 83 qedx: Do you wish to continue?");
 84 
 85 dcl  RECURSION_EXPLANATION character (920) defined (RECURSION_EXPLANATION_SECTIONS.part1) position (1);
 86                                                             /* last part is only 120 characters */
 87 
 88 dcl  sys_info$max_seg_size fixed binary (19) external;
 89 
 90 /* format: off */
 91 dcl (error_table_$badopt, error_table_$bigarg, error_table_$inconsistent, error_table_$noarg, error_table_$too_many_args)
 92           fixed binary (35) external;
 93 /* format: on */
 94 
 95 dcl  com_err_ entry () options (variable);
 96 dcl  command_query_$yes_no entry () options (variable);
 97 dcl  cu_$arg_count entry (fixed binary, fixed binary (35));
 98 dcl  cu_$arg_ptr entry (fixed binary, pointer, fixed binary (21), fixed binary (35));
 99 dcl  expand_pathname_$component entry (character (*), character (*), character (*), character (*), fixed binary (35));
100 dcl  expand_pathname_$component_add_suffix
101           entry (character (*), character (*), character (*), character (*), character (*), fixed binary (35));
102 dcl  get_temp_segment_ entry (character (*), pointer, fixed binary (35));
103 dcl  initiate_file_$component
104           entry (character (*), character (*), character (*), bit (*), pointer, fixed binary (24), fixed binary (35));
105 dcl  pathname_$component entry (character (*), character (*), character (*)) returns (character (194));
106 dcl  qedx_ entry (pointer, fixed binary (35));
107 dcl  release_temp_segment_ entry (character (*), pointer, fixed binary (35));
108 dcl  terminate_file_ entry (pointer, fixed binary (24), bit (*), fixed binary (35));
109 dcl  cleanup condition;
110 
111 dcl  (divide, length, index, null, substr, string) builtin;
112 %page;
113 /* qedx: qx: procedure () options (variable); */
114 
115           call cu_$arg_count (n_arguments, code);
116           if code ^= 0 then do;
117                call com_err_ (code, QEDX);
118                return;
119           end;
120 
121           if invocation_level > 0 then do;                  /* it would be nice to eliminate this... */
122                call command_query_$yes_no (ok_to_continue, 0, QEDX, RECURSION_EXPLANATION,
123                     "There ^[are^;is^] ^d suspended invocation^[s^;^] of qedx in your process.^/Do you wish to continue?",
124                     (invocation_level > 1), invocation_level, (invocation_level > 1));
125                if ^ok_to_continue then return;
126           end;
127 
128           invocation_level = invocation_level + 1;          /* another qedx */
129 
130           input_file_ptr,                                   /* for cleanup handler */
131                exec_buffer_ptr, args_buffer_ptr = null ();
132 
133           on condition (cleanup) call cleanup_qedx_invocation ();
134 
135 
136 /* format: off */
137 
138 /* Process arguments: syntax of the qedx command is --
139 
140       qedx {-control_args} {macro_path {macro_arguments}} */
141 
142 /* format: on */
143 
144           no_rw_path,                                       /* allow r/w with pathnames and R/W */
145                have_pathname,                               /* haven't seen -pathname yet */
146                have_macro_pathname,                         /* haven't seen first non-control argument yet */
147                have_macro_arguments = "0"b;                 /* haven't seen any macro arguments */
148 
149           do argument_idx = 1 to n_arguments;
150 
151                call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code);
152                if code ^= 0 then do;                        /* sigh */
153                     call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx);
154                     go to RETURN_FROM_QEDX;
155                end;
156 
157                if ^have_macro_pathname then                 /* no non-control argument yet: can still accept -ca's */
158                     if index (argument, "-") = 1 then       /* ... a control argument */
159                          if argument = "-no_rw_path" then no_rw_path = "1"b;
160                          else if argument = "-rw_path" then no_rw_path = "0"b;
161 
162                          else if (argument = "-pathname") | (argument = "-pn") then
163                               if have_pathname then do;
164                                    call com_err_ (error_table_$too_many_args, QEDX,
165                                         """-pathname"" may only be specified once for this command.");
166                                    go to RETURN_FROM_QEDX;
167                               end;
168                               else do;                      /* initial contents for buffer 0 ... */
169                                    have_pathname = "1"b;
170                                    if argument_idx = n_arguments then do;
171                                         call com_err_ (error_table_$noarg, QEDX, "Pathname after ""^a"".", argument);
172                                         go to RETURN_FROM_QEDX;
173                                    end;
174                                    argument_idx = argument_idx + 1;
175                                    call cu_$arg_ptr (argument_idx, argument_ptr, argument_lth, code);
176                                    if code ^= 0 then do;
177                                         call com_err_ (code, QEDX, "Fetching argument #^d.", argument_idx);
178                                         go to RETURN_FROM_QEDX;
179                                    end;
180                                    call expand_pathname_$component (argument, input_dirname, input_ename, input_component,
181                                         code);
182                                    if code ^= 0 then do;
183                                         call com_err_ (code, QEDX, "-pathname ^a", argument);
184                                         go to RETURN_FROM_QEDX;
185                                    end;
186                                    call initiate_file_$component (input_dirname, input_ename, input_component, R_ACCESS,
187                                         input_file_ptr, (0), code);
188                                    if code ^= 0 then do;    /* the file doesn't exist (sigh) */
189                                         call com_err_ (code, QEDX, "-pathname ^a",
190                                              pathname_$component (input_dirname, input_ename, input_component));
191                                         go to RETURN_FROM_QEDX;
192                                    end;
193                                    call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0));
194                                    input_file_ptr = null ();
195                               end;
196 
197                          else do;
198                               call com_err_ (error_table_$badopt, QEDX, """^a""", argument);
199                               go to RETURN_FROM_QEDX;
200                          end;
201 
202                     else do;                                /* first non-control argument: macro pathname */
203                          have_macro_pathname = "1"b;
204                          call expand_pathname_$component_add_suffix (argument, QEDX, exec_dirname, exec_ename,
205                               exec_component, code);
206                          if code ^= 0 then do;
207                               call com_err_ (code, QEDX, "Macro file: ^a", argument);
208                               go to RETURN_FROM_QEDX;
209                          end;
210                          call initiate_file_$component (exec_dirname, exec_ename, exec_component, R_ACCESS,
211                               exec_buffer_ptr, exec_buffer_bc, code);
212                          if code ^= 0 then do;              /* the file doesn't exist (sigh) */
213                               call com_err_ (code, QEDX, "Macro file: ^a",
214                                    pathname_$component (exec_dirname, exec_ename, exec_component));
215                               go to RETURN_FROM_QEDX;
216                          end;
217                     end;
218 
219                else do;                                     /* Nth non-control argument: a macro argument */
220                     if ^have_macro_arguments then do;       /* ... first macro argument */
221                          call get_temp_segment_ (QEDX, args_buffer_ptr, code);
222                          if code ^= 0 then do;
223                               call com_err_ (code, QEDX, "Obtaining buffer space for macro arguments.");
224                               go to RETURN_FROM_QEDX;
225                          end;
226                          args_buffer_used = 0;
227                          have_macro_arguments = "1"b;
228                     end;
229                     call add_to_args_buffer (argument);
230                     call add_to_args_buffer (NL);
231                end;
232           end;
233 
234           if no_rw_path & ^have_pathname then do;
235                call com_err_ (error_table_$inconsistent, QEDX, """-no_rw_path"" must be used with ""-pathname"".");
236                go to RETURN_FROM_QEDX;
237           end;
238 
239 
240 /* Arguments have been validated: setup qedx_info data structure and invoke qedx_ */
241 
242           local_qi.header.version = QEDX_INFO_VERSION_1;
243           local_qi.header.editor_name = QEDX;
244 
245           string (local_qi.header.flags) = ""b;
246           local_qi.header.no_rw_path = no_rw_path;
247           local_qi.header.query_if_modified = "1"b;         /* finally after all these years ... */
248 
249           local_qi.header.n_buffers = 0;                    /* no initial buffers yet */
250 
251           if have_pathname then do;                         /* include a buffer 0 containing requested file ... */
252                local_qi.header.n_buffers, idx = 1;
253                local_qi.buffers (idx).buffer_name = "0";
254                local_qi.buffers (idx).buffer_pathname = pathname_$component (input_dirname, input_ename, input_component);
255                string (local_qi.buffers (idx).flags) = ""b;
256           end;
257 
258           if have_macro_pathname then do;                   /* exec buffer containing a macro to execute ... */
259                local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1;
260                local_qi.buffers (idx).buffer_name = "exec";
261                local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */
262                local_qi.buffers (idx).region_ptr = exec_buffer_ptr;
263                local_qi.buffers (idx).region_max_lth,       /* ... get size from the system */
264                     local_qi.buffers (idx).region_initial_lth = divide ((exec_buffer_bc + 8), 9, 21, 0);
265                string (local_qi.buffers (idx).flags) = ""b;
266                local_qi.buffers (idx).read_write_region, local_qi.buffers (idx).execute_buffer = "1"b;
267           end;                                              /* ... get initial content from us but can't write back */
268 
269           if have_macro_arguments then do;                  /* a "file" of arguments to the macro ... */
270                local_qi.header.n_buffers, idx = local_qi.header.n_buffers + 1;
271                local_qi.buffers (idx).buffer_name = "args";
272                local_qi.buffers (idx).buffer_pathname = ""; /* ... no pathname by default */
273                local_qi.buffers (idx).region_ptr = args_buffer_ptr;
274                local_qi.buffers (idx).region_max_lth, local_qi.buffers (idx).region_initial_lth = args_buffer_used;
275                string (local_qi.buffers (idx).flags) = ""b;
276                local_qi.buffers (idx).read_write_region = "1"b;
277           end;                                              /* ... get initial content from us but can't write back */
278 
279 
280           call qedx_ (addr (local_qi), code);               /* INVOKE THE EDITOR */
281 
282 
283 RETURN_FROM_QEDX:
284           call cleanup_qedx_invocation ();
285 
286           return;
287 %page;
288 /* Add a character string to the macro arguments buffer */
289 
290 add_to_args_buffer:
291      procedure (p_string);
292 
293 dcl  p_string character (*) parameter;
294 
295           if (args_buffer_used + length (p_string)) > length (args_buffer) then do;
296                call com_err_ (error_table_$bigarg, QEDX, "Too many macro arguments.  First failing argument: ""^a"".",
297                     argument);
298                go to RETURN_FROM_QEDX;
299           end;
300 
301           substr (args_buffer, (args_buffer_used + 1), length (p_string)) = p_string;
302           args_buffer_used = args_buffer_used + length (p_string);
303 
304           return;
305 
306      end add_to_args_buffer;
307 
308 
309 
310 /* Cleanup after an invocation of qedx */
311 
312 cleanup_qedx_invocation:
313      procedure ();
314 
315           if input_file_ptr ^= null () then do;             /* a very small window nonetheless ... */
316                call terminate_file_ (input_file_ptr, 0, TERM_FILE_TERM, (0));
317                input_file_ptr = null ();
318           end;
319 
320           if exec_buffer_ptr ^= null () then do;
321                call terminate_file_ (exec_buffer_ptr, 0, TERM_FILE_TERM, (0));
322                exec_buffer_ptr = null ();
323           end;
324 
325           if args_buffer_ptr ^= null () then do;
326                call release_temp_segment_ (QEDX, args_buffer_ptr, (0));
327                args_buffer_ptr = null ();
328           end;
329 
330           invocation_level = invocation_level - 1;          /* all gone */
331 
332           return;
333 
334      end cleanup_qedx_invocation;
335 %page;
336 %include qedx_info;
337 %page;
338 %include access_mode_values;
339 
340 %include terminate_file;
341 
342      end qedx;