1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Bull Inc., 1989                *
  6         *                                                         *
  7         * Copyright, (C) Honeywell Information Systems Inc., 1986 *
  8         *                                                         *
  9         *********************************************************** */
 10 
 11 
 12 
 13 /****^  HISTORY COMMENTS:
 14   1) change(86-08-21,Fakoury), approve(86-08-21,MCR7515),
 15      audit(87-01-07,Farley), install(87-01-08,MR12.0-1263):
 16      Originally coded 0682 by R. Fakoury for MR12.
 17   2) change(89-11-08,Fakoury), approve(89-11-20,MECR0014),
 18      audit(89-11-09,Parisek), install(89-11-20,MR12.3-1120):
 19      To correct the path for the info dir.
 20   3) change(89-11-20,Fakoury), approve(89-11-20,PBF8146),
 21      audit(89-11-20,Parisek), install(89-11-20,MR12.3-1120):
 22      Again, correct info dir problem. Let ssu_ figure it out.
 23                                                    END HISTORY COMMENTS */
 24 
 25 
 26 /* The deckfile_manager command provides the functionallity to maintain a tandd_deck_file */
 27 
 28 
 29 /* format: style4,ifthenstmt,ifthen,ind3,ll125,lineconind1 */
 30 deckfile_manager:
 31 dfm: proc ();
 32 
 33 
 34 /* Automatic */
 35 
 36 dcl  ab_sw bit (1) aligned;
 37 dcl  argl fixed bin (21);
 38 dcl  argp ptr;
 39 dcl  arg_num fixed bin;
 40 dcl  code fixed bin (35);
 41 dcl  debug_sw bit (1) aligned;
 42 dcl  deckfile_length fixed bin (21);
 43 dcl  deckfile_ptr ptr;
 44 dcl  nargs fixed bin;
 45 dcl  profile_dir char (168);
 46 dcl  profile_entry char (32);
 47 dcl  profile_length fixed bin (21);
 48 dcl  profile_ptr ptr;
 49 dcl  profile_sw bit (1);
 50 dcl  prompt_length fixed bin (21);
 51 dcl  prompt_ptr ptr;
 52 dcl  prompt_sw bit (1);
 53 dcl  quit_sw bit (1);
 54 dcl  request_loop_sw bit (1);
 55 dcl  ready_sw bit (1) aligned;
 56 dcl  request_sw bit (1);
 57 dcl  request_line_length fixed bin (21);
 58 dcl  request_line_ptr ptr;
 59 dcl  sci_ptr ptr;
 60 dcl  startup_sw bit (1);
 61 
 62 /*  Based */
 63 
 64 dcl  arg char (argl) based (argp);
 65 dcl  deckfile_string char (deckfile_length) based (deckfile_ptr);
 66 dcl  free_area area based (get_system_free_area_ ());
 67 dcl  profile_string char (profile_length) based (profile_ptr);
 68 dcl  prompt_string char (prompt_length) aligned based (prompt_ptr);
 69 
 70 
 71 /*  Builtins */
 72 
 73 dcl  addr builtin;
 74 dcl  codeptr builtin;
 75 dcl  null builtin;
 76 
 77 
 78 /* Conditions */
 79 
 80 dcl  cleanup condition;
 81 
 82 
 83 /* Constants */
 84 
 85 dcl  dfm_version_1 char (4) int static options (constant) init ("1.0a");
 86 dcl  false bit (1) int static options (constant) init ("0"b);
 87 dcl  last_position fixed bin int static options (constant) init (9999);
 88 dcl  max_prompt_length fixed bin int static options (constant) init (64);
 89 dcl  myname char (3) int static options (constant) init ("dfm");
 90 dcl  true bit (1) int static options (constant) init ("1"b);
 91 
 92 /* Entries */
 93 
 94 dcl  active_fnc_err_ entry options (variable);
 95 dcl  com_err_ entry () options (variable);
 96 dcl  cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 97 dcl  cu_$arg_list_ptr entry () returns (ptr);
 98 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 99 dcl  cu_$generate_call entry (entry, ptr);
100 dcl  dfm_$clean_up entry (ptr, ptr);
101 dcl  dfm_$pi_handler entry;
102 dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
103 dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
104 dcl  get_system_free_area_ entry () returns (ptr);
105 dcl  initiate_file_ entry (char (*), char (*), bit (*), ptr, fixed bin (24), fixed bin (35));
106 dcl  ssu_$add_info_dir entry (ptr, char (*), fixed bin, fixed bin (35));
107 dcl  ssu_$add_request_table entry (ptr, ptr, fixed bin, fixed bin (35));
108 dcl  ssu_$create_invocation entry (char (*), char (*), ptr, ptr, char (*), ptr, fixed bin (35));
109 dcl  ssu_$destroy_invocation entry (ptr);
110 dcl  ssu_$execute_line entry (ptr, ptr, fixed bin (21), fixed bin (35));
111 dcl  ssu_$execute_start_up entry () options (variable);
112 dcl  ssu_$get_temp_segment entry (ptr, char (*), ptr);
113 dcl  ssu_$listen entry (ptr, ptr, fixed bin (35));
114 dcl  ssu_$record_usage entry (ptr, ptr, fixed bin (35));
115 dcl  ssu_$release_temp_segment entry (ptr, ptr);
116 dcl  ssu_$set_abbrev_info entry (ptr, ptr, ptr, bit (1) aligned);
117 dcl  ssu_$set_debug_mode entry (ptr, bit (1) aligned);
118 dcl  ssu_$set_ec_suffix entry (ptr, char (32));
119 dcl  ssu_$set_procedure entry (ptr, char (*), entry, fixed bin (35));
120 dcl  ssu_$set_prompt entry (ptr, char (64) var);
121 dcl  ssu_$set_prompt_mode entry (ptr, bit (*));
122 dcl  ssu_$set_ready_mode entry (ptr, bit (1) aligned);
123 
124 /* External */
125 
126 dcl  dfm_request_table_$dfm_request_table_ fixed bin ext static;
127 dcl  error_table_$active_function fixed bin (35) ext static;
128 dcl  error_table_$badopt fixed bin (35) ext static;
129 dcl  error_table_$bigarg fixed bin (35) ext static;
130 dcl  error_table_$inconsistent fixed bin (35) ext static;
131 dcl  error_table_$not_act_fnc fixed bin (35) ext static;
132 dcl  ssu_et_$subsystem_aborted fixed bin (35) ext static;
133 dcl  ssu_et_$program_interrupt fixed bin (35) ext static;
134 dcl  ssu_et_$null_request_line fixed bin (35) ext static;
135 dcl  ssu_et_$request_line_aborted fixed bin (35) ext static;
136 dcl  ssu_info_directories_$standard_requests char (168) external;
137 dcl  ssu_request_tables_$standard_requests bit (36) aligned external;
138 
139 
140 %page;
141 
142       call cu_$af_return_arg (nargs, null (), 0, code);
143       if code ^= error_table_$not_act_fnc then do;
144          if code = 0 then call active_fnc_err_ (error_table_$active_function, myname);
145          else call com_err_ (code, myname);
146          return;
147       end;
148 
149       call dfm_init ();
150 
151       on cleanup call deckfile_manager_cleanup ();
152 
153       do arg_num = 1 to nargs;                              /* process all the arguments                      */
154          call cu_$arg_ptr (arg_num, argp, argl, code);
155          if code ^= 0 then call complain (code, myname, "Getting arg ptr.");
156 
157          if arg = "-abbrev" | arg = "-ab" then ab_sw = true;
158 
159          else if arg = "-debug" | arg = "-db" then debug_sw = true;
160 
161          else if arg = "-deckfile" | arg = "-dkf" then do;
162             call next_arg (deckfile_ptr, deckfile_length, code);
163             if code ^= 0 then call complain (code, myname, "Getting deckfile pathname.");
164             call expand_pathname_ (deckfile_string, dfm_info.deckfile_dir,
165              dfm_info.deckfile_entry, code);
166             if code ^= 0 then call complain (code, myname, "Expanding deckfile pathname.");
167          end;
168 
169          else if arg = "-no_abbrev" | arg = "-nab" then ab_sw = false;
170 
171          else if arg = "-no_debug" | arg = "-ndb" then debug_sw = false;
172 
173          else if arg = "-no_prompt" then prompt_sw = false;
174 
175          else if arg = "-no_startup" | arg = "-nsu" then startup_sw = false;
176 
177          else if arg = "-profile" | arg = "-pf" then do;
178             call next_arg (profile_ptr, profile_length, code);
179             if code ^= 0 then call complain (code, myname, "Getting profile pathname.");
180             call expand_pathname_$add_suffix (profile_string, "profile", profile_dir, profile_entry, code);
181             if code ^= 0 then call complain (code, myname, "Expanding profile pathname.");
182             call initiate_file_ (profile_dir, profile_entry, R_ACCESS, profile_ptr, 0, code);
183             if profile_ptr = null () then call complain (code, myname,
184                 "Initiating the profile ^a>^a.", profile_dir, profile_entry);
185 
186             ab_sw, profile_sw = true;
187          end;
188 
189          else if arg = "-prompt" then do;
190             call next_arg (prompt_ptr, prompt_length, code);
191             if code ^= 0 then call complain (code, myname, "Getting prompt string");
192             if prompt_length > max_prompt_length then
193                call complain (error_table_$bigarg, myname,
194                 "The prompt may be a maximum of ^d characters", max_prompt_length);
195             prompt_sw = true;
196          end;
197 
198          else if arg = "-quit" | arg = "-q" then
199             quit_sw, dfm_info.flags.force_quit = true;
200 
201          else if arg = "-ready_off" | arg = "-rdf" then ready_sw = false;
202 
203          else if arg = "-ready_on" | arg = "-rdn" then ready_sw = true;
204 
205          else if arg = "-request" | arg = "-rq" then do;
206             if request_sw then call complain (error_table_$inconsistent,
207                 myname, "Only one request per invocation");
208             call next_arg (request_line_ptr, request_line_length, code);
209             if code ^= 0 then call complain (code, myname, "Getting request line");
210             request_sw = true;
211          end;
212 
213          else if arg = "-request_loop"
214           | arg = "-rql" then request_loop_sw = true;
215 
216          else if arg = "-startup" | arg = "su" then startup_sw = true;
217 
218          else call complain (error_table_$badopt, myname, "^a", arg);
219 
220       end;                                                  /* end argument processing */
221 
222       call ssu_$create_invocation (myname, dfm_version_1, dfm_infop,
223        addr (dfm_request_table_$dfm_request_table_), ">doc>subsystem>dfm", sci_ptr, code);
224       if code ^= 0 then call complain (code, myname, "Creating subsystem invocation.");
225 
226       call ssu_$record_usage (sci_ptr, codeptr (dfm), 0);
227 
228       call ssu_$add_info_dir (sci_ptr, ssu_info_directories_$standard_requests, last_position, code);
229       if code ^= 0 then call complain (code, myname, "Adding ssu info dir.");
230 
231       call ssu_$add_request_table (sci_ptr, addr (ssu_request_tables_$standard_requests), last_position, code);
232       if code ^= 0 then call complain (code, myname, "Adding ssu request table.");
233 
234       call ssu_$set_procedure (sci_ptr, "program_interrupt", dfm_$pi_handler, code);
235       if code ^= 0 then call complain (code, myname, "Adding pi handler.");
236 
237       call ssu_$set_ec_suffix (sci_ptr, "dfmec");
238 
239       call ssu_$get_temp_segment (sci_ptr, "dfm_data", dfm_info.dfm_data_ptr);
240 
241       call ssu_$set_abbrev_info (sci_ptr, profile_ptr, profile_ptr, ab_sw);
242 
243       call ssu_$set_debug_mode (sci_ptr, debug_sw);
244 
245       if prompt_sw & prompt_length > 0 then
246          call ssu_$set_prompt (sci_ptr, (prompt_string));
247 
248       call ssu_$set_prompt_mode (sci_ptr, ^prompt_sw);
249 
250       call ssu_$set_ready_mode (sci_ptr, ready_sw);
251 
252       if startup_sw then do;
253          call ssu_$execute_start_up (sci_ptr, code);
254          if code ^= 0 then call complain (code, myname, "Executing ssu startup.");
255       end;
256 
257       if request_sw then do;
258          call ssu_$execute_line (sci_ptr, request_line_ptr, request_line_length, code);
259          if code ^= 0 then do;
260             if (code = ssu_et_$null_request_line
261              | code = ssu_et_$program_interrupt
262              | code = ssu_et_$request_line_aborted)
263              & request_loop_sw then goto listen;
264             else if code = ssu_et_$subsystem_aborted then goto subsystem_wrapup; /* normal end of subsystem */
265             else call complain (code, myname, "Encountered while executing request line");
266          end;
267       end;
268 
269       if quit_sw then goto subsystem_wrapup;
270 
271 
272 listen:
273       call ssu_$listen (sci_ptr, null (), code);
274       if code ^= ssu_et_$subsystem_aborted then
275          call com_err_ (code, myname, "Calling the listener.");
276 
277 subsystem_wrapup:
278       call deckfile_manager_cleanup ();
279       return;
280 %page;
281 
282 /* complain - an internal proc to print an error message and wrapup. */
283 
284 
285 complain: proc () options (variable);
286 
287       call cu_$generate_call (com_err_, cu_$arg_list_ptr ());
288       goto subsystem_wrapup;
289 
290 
291    end complain;
292 
293 
294 
295 %page;
296 
297 /* deckfile_manager_cleanup - internal proc to cleanup a deckfile_manager invocation. */
298 
299 
300 deckfile_manager_cleanup: proc ();
301 
302       if dfm_infop ^= null then do;
303 
304          if dfm_info.flags.request_active then call dfm_$clean_up (sci_ptr, dfm_infop);
305 
306          if dfm_info.dfm_data_ptr ^= null () then
307             call ssu_$release_temp_segment (sci_ptr, dfm_info.dfm_data_ptr);
308 
309          if sci_ptr ^= null then call ssu_$destroy_invocation (sci_ptr);
310 
311          free dfm_info in (free_area);
312          dfm_infop = null;
313       end;
314 
315 
316    end deckfile_manager_cleanup;
317 %page;
318 
319 /* Internal proc that initializes dfm variables */
320 
321 dfm_init: proc ();
322 
323       dfm_infop = null;
324       allocate dfm_info in (free_area) set (dfm_infop);
325 
326       ab_sw = false;
327       debug_sw = false;
328       dfm_info.deckfile_dir = "";
329       dfm_info.deckfile_entry = "";
330       dfm_info.dfm_data_ptr = null;
331       dfm_info.page_number = 0;
332       dfm_info.flags.request_active = false;
333       dfm_info.force_quit = false;
334       dfm_info.pad = "0"b;
335       dfm_info.version = dfm_info_version_1;
336       profile_ptr = null;
337       profile_sw = false;
338       prompt_length = 0;
339       prompt_ptr = null;
340       prompt_sw = true;                                     /* default is to prompt */
341       quit_sw = false;
342       request_loop_sw = false;
343       ready_sw = false;
344       request_sw = false;
345       request_line_length = 0;
346       request_line_ptr = null;
347       sci_ptr = null;
348       startup_sw = false;
349 
350    end dfm_init;
351 
352 %page;
353 
354 /*  Internal proc that gets the next argument from the argument string, complaining if it's not there  */
355 
356 next_arg: proc (nargp, nargl, nacode);
357 
358 dcl  nargp ptr;
359 dcl  nacode fixed bin (35);
360 dcl  nargl fixed bin (21);
361 
362       arg_num = arg_num + 1;
363       call cu_$arg_ptr (arg_num, nargp, nargl, nacode);
364 
365 
366    end next_arg;
367 
368 %page;
369 %include access_mode_values;
370 %page;
371 %include dfm_info;
372 %page;
373 %include ssu_prompt_modes;
374 
375    end deckfile_manager;