1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1988                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 
 10 /****^  HISTORY COMMENTS:
 11   1) change(88-01-27,Dupuis), approve(88-03-03,MCR7844), audit(88-03-14,Blair),
 12      install(88-03-15,MR12.2-1036):
 13      Implemented the -progress/-no_progress control arguments.
 14                                                    END HISTORY COMMENTS */
 15 
 16 
 17 /* format: off */
 18 %skip(3);
 19 /*   This is the main level procedure called by ssu_ to implement the
 20      linus write request. Description and usage follows.
 21 
 22      Description:
 23 
 24      This request retrieves the selected data from the data base and writes
 25      it to a file.
 26 
 27      Usage: "write pathname {-control_args}"
 28 
 29      where pathname is the name of the file which will contain the data.
 30 
 31      -control_args can be:
 32 
 33      -column_delimiter X -- the delimiter used to separate column values.
 34      X can be any single ascii character (default is one blank). The old
 35      control arg -delimiter is still accepted but not documented.
 36 
 37      -extend -- the file is extended rather than truncated.
 38 
 39      -progress {N} -- prints a progress report every N tuples, where N defaults
 40      to linus_data_$trace_every_n_tuples if not specified.
 41 
 42      -row_delimiter X -- the delimiter used to separate rows. X can be any
 43      single ascii character (default is newline character).
 44 
 45      -truncate -- the file is truncated rather than extended (default).
 46 
 47      Both parameters are passed to this request by ssu_.
 48 
 49 
 50      Known Bugs:
 51 
 52      Other Problems:
 53 
 54      History:
 55 
 56      Written - Al Dupuis - September 1983 - complete rewrite of old module.
 57 
 58 */
 59 %page;
 60 linus_write: proc (
 61 
 62           sci_ptr_parm,   /* input: ptr to the subsystem control info structure */
 63           lcb_ptr_parm    /* input: ptr to the linus control block info structure */
 64                          );
 65 %skip(3);
 66 dcl sci_ptr_parm ptr parm;
 67 dcl lcb_ptr_parm ptr parm;
 68 %skip(3);
 69 /*
 70      Mainline Processing Overview:
 71 
 72      (1) Process control arguments setting flags and collecting values.
 73 
 74      (2) Have the subroutine do all the work (it reports errors and calls
 75          ssu_$abort_line if things don't go well).
 76 
 77 */
 78 %skip(3);
 79           call initialize;
 80           call process_args;
 81           call linus_create_data_file (lcb_ptr, addr (data_file_info));
 82 %skip(1);
 83           return;
 84 %page;
 85 initialize: proc;
 86 %skip(3);
 87           sci_ptr = sci_ptr_parm;
 88           lcb_ptr = lcb_ptr_parm;
 89 %skip(1);
 90           unspec (data_file_info) = OFF;
 91           data_file_info.column_delimiter = BLANK;
 92           data_file_info.row_delimiter = NEWLINE;
 93           data_file_info.flags.truncate_file = ON;
 94           data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples;
 95 %skip(1);
 96           call ssu_$arg_count (sci_ptr, number_of_args_supplied);
 97           if number_of_args_supplied = 0
 98           then call ssu_$abort_line (sci_ptr, error_table_$noarg,
 99                "An output file pathname must be supplied.");
100 %skip(1);
101           call ssu_$arg_ptr (sci_ptr, 1, arg_ptr, arg_length);
102           data_file_info.output_file_pathname = arg;
103 %skip(1);
104           return;
105 %skip(1);
106      end initialize;
107 %page;
108 process_args: proc;
109 
110           do current_arg_number = 2 to number_of_args_supplied;
111 
112                call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length);
113 
114                if arg = "-extend"
115                then data_file_info.flags.truncate_file = OFF;
116                else if arg = "-truncate" | arg = "-tc"
117                then data_file_info.flags.truncate_file = ON;
118                else if arg = "-no_progress" | arg = "-npg"
119                then do;
120                     data_file_info.flags.tracing = OFF;
121                     data_file_info.trace_every_n_tuples = linus_data_$trace_every_n_tuples;
122                end;
123                else if arg = "-progress" | arg = "-pg"
124                then call setup_tracing;
125                else if arg = "-column_delimiter" | arg = "-cdm"
126                | arg = "-delimiter" | arg = "-dm" | arg = "-row_delimiter" | arg = "-rdm"
127                then call setup_delimiter;
128                else call ssu_$abort_line (sci_ptr, error_table_$badopt,
129                     "^a is not a valid control argument.", arg);
130           end;
131 
132           return;
133 %page;
134 setup_delimiter: proc;
135 
136           if current_arg_number + 1 > number_of_args_supplied
137           then call ssu_$abort_line (sci_ptr, error_table_$inconsistent,
138                "^/^[-row_delimiter^;-column_delimiter^] must be followed by a delimiter.",
139                (arg = "-row_delimiter" | arg = "-rdm"));
140 
141           current_arg_number = current_arg_number + 1;
142           call ssu_$arg_ptr (sci_ptr, current_arg_number, arg_ptr, arg_length);
143           if arg_length ^= 1
144           then call ssu_$abort_line (sci_ptr, 0,
145                "The specified delimiter ""^a"" is not a single ascii character.", arg);
146           if (arg = "-row_delimiter" | arg = "-rdm")
147           then data_file_info.row_delimiter = arg;
148           else data_file_info.column_delimiter = arg;
149 
150           return;
151 
152      end setup_delimiter;
153 %page;
154 setup_tracing: proc;
155 
156           data_file_info.tracing = ON;
157 
158           if current_arg_number + 1 > number_of_args_supplied
159           then return;
160 
161           call ssu_$arg_ptr (sci_ptr, current_arg_number + 1, arg_ptr, arg_length);
162           if verify (arg, "01234546789") = 0
163           then do;
164                data_file_info.trace_every_n_tuples = convert (data_file_info.trace_every_n_tuples, arg);
165                current_arg_number = current_arg_number + 1;
166           end;
167 
168           return;
169 
170      end setup_tracing;
171 
172      end process_args;
173 %page;
174 dcl BLANK char (1) static internal options (constant) init (" ");
175 %skip(1);
176 dcl NEWLINE char (1) static internal options (constant) init ("
177 ");
178 %skip(1);
179 dcl OFF bit (1) aligned static internal options (constant) init ("0"b);
180 dcl ON bit (1) aligned static internal options (constant) init ("1"b);
181 %skip(1);
182 dcl addr builtin;
183 dcl arg char (arg_length) based (arg_ptr);
184 dcl arg_length fixed bin (21);
185 dcl arg_ptr ptr;
186 %skip(1);
187 dcl current_arg_number fixed bin;
188 %skip(1);
189 dcl error_table_$badopt fixed bin(35) ext static;
190 dcl error_table_$inconsistent fixed bin(35) ext static;
191 dcl error_table_$noarg fixed bin(35) ext static;
192 %skip(1);
193 dcl lcb_ptr ptr;
194 dcl linus_create_data_file entry (ptr, ptr);
195 dcl linus_data_$trace_every_n_tuples fixed bin (35) external static;
196 %skip(1);
197 dcl number_of_args_supplied fixed bin;
198 %skip(1);
199 dcl sci_ptr ptr;
200 dcl ssu_$abort_line entry() options(variable);
201 dcl ssu_$arg_count entry (ptr, fixed bin);
202 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin(21));
203 %skip(1);
204 dcl unspec builtin;
205 %page;
206 %include linus_data_file_info;
207 %skip(3);
208      end linus_write;