1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Information Systems Inc., 1981 *
  4         *                                                         *
  5         * Copyright (c) 1972 by Massachusetts Institute of        *
  6         * Technology and Honeywell Information Systems, Inc.      *
  7         *                                                         *
  8         *********************************************************** */
  9 
 10 
 11 
 12 
 13 
 14 /****^  HISTORY COMMENTS:
 15   1) change(86-10-20,TLNguyen), approve(86-10-20,MCR7560),
 16      audit(86-10-22,Gilcrease), install(86-10-22,MR12.0-1195):
 17      Correct an usage message.
 18                                                    END HISTORY COMMENTS */
 19 
 20 
 21 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
 22 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
 23 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
 24 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
 25 
 26 /* Created: Mar 78  J Falksen                                                */
 27 /* Updated: Aug 78  J Falksen                                                */
 28 /*   added conversion handler                                                */
 29 /*   fixed error message                                                     */
 30 /*   added valid_pictured_data entry                                         */
 31 /*   removed quotes from command output                                      */
 32 /*   made command use NL separator when multiple output values               */
 33 /* Updated: Aug 80  J Falksen                                                */
 34 /*   cleanup for installation and format_pl1                                 */
 35 /* Updated: Oct. 86 Tai L. Nguyen                                            */
 36 /*   corrected an usage message                                              */
 37 
 38 /* Syntax:  pic pic_string values {-control_arg}                             */
 39 /*                                                                           */
 40 /* Function: returns one or more values processed through a specified        */
 41 /* PL/I picture.                                                             */
 42 /*                                                                           */
 43 /* Arguments:                                                                */
 44 /* pic_string                                                                */
 45 /*    is a valid PL/I picture as defined in the PL/I Reference Manual and    */
 46 /*    the PL/I Language Specification.                                       */
 47 /* values                                                                    */
 48 /*    are strings having data appropriate for editing into the picture.      */
 49 /*    Each value must be convertible to the type implied by the picture      */
 50 /*    specified.  If multiple values are presented, the results are          */
 51 /*    separated by single spaces.  Any resulting value that contains a       */
 52 /*    space is quoted.                                                       */
 53 /*                                                                           */
 54 /* Control argument:                                                         */
 55 /* -strip                                                                    */
 56 /*    removes leading spaces from edited picture values; removes trailing    */
 57 /*    zeros following a decimal point; removes a decimal point if it would   */
 58 /*    have been the last character of a returned value.                      */
 59 /*                                                                           */
 60 /*                                                                           */
 61 /* Syntax as active function:  [pic pic_string values {-control_arg}]        */
 62 
 63 /* Syntax:  [vpd pic_string values]                                          */
 64 /*                                                                           */
 65 /* Function: Returns "true" if all values can be formatted via pic_string.   */
 66 /* Otherwise returns "false".                                                */
 67 /*                                                                           */
 68 /*                                                                           */
 69 /* Arguments:                                                                */
 70 /* pic_string                                                                */
 71 /*    is a valid PL/I picture.                                               */
 72 /* value                                                                     */
 73 /*    is a string to be edited into the picture.                             */
 74 /*                                                                           */
 75 /*                                                                           */
 76 /* Notes:  For more information on PL/I picture and picture strings, see     */
 77 /* the PL/I Reference Manual, Order No.  AM83 or the PL/I Language           */
 78 /* Specification, Order No. AG94.                                            */
 79 
 80 pic: picture: proc;                     /* edit a value into a picture       */
 81 
 82       testing = "0"b;
 83       me = "picture";
 84       goto start;
 85 
 86 valid_pictured_data: vpd: entry;        /* see if value will edit into pic   */
 87 
 88       testing = "1"b;
 89       me = "valid_pictured_data";
 90       goto start;
 91 
 92 start:
 93       strip_sw = "0"b;                  /* dont strip leading/trailing       */
 94       call cu_$af_arg_count (argct, code);
 95       if (code ^= 0)                    /* called as command?                */
 96       then do;                          /* ...YES                            */
 97          retval_p = null ();            /* no return string                  */
 98          error = com_err_;              /* set error message routine         */
 99          arg_ptr = cu_$arg_ptr;
100       end;
101       else do;                          /* ...NO                             */
102          call cu_$af_return_arg (argct, retval_p, retval_l, code);
103                                         /* get return string                 */
104          retval = "";
105          error = active_fnc_err_;       /* set error message routine         */
106          arg_ptr = cu_$af_arg_ptr;
107       end;
108       if (argct < 2)
109       then do;                          /* tsk, tsk                          */
110          if (me = "picture")
111          then call error (error_table_$noarg, me,
112                  "Usage:^-pic pic_str {-strip} value ...");
113          else call error (error_table_$noarg, me,
114                  "Usage:^-vpd pic_str value ...");
115          return;
116       end;
117       call arg_ptr (1, argp, argl, code); /* get the picture string          */
118       if (argl = 0)                     /* he wants the default              */
119       then do;
120          the_picture = default;
121          picp = addr (default);
122          picl = length (default);       /* which include NO extraneous       */
123          strip_sw = "1"b;               /*  spaces or blanks                 */
124 dcl default         char (13) int static options (constant)
125                     init ("(15)-9v.(15)9");
126       end;
127       else do;                          /* use his picture  (SMILE!)         */
128          the_picture = arg;
129          picp = argp;
130          picl = argl;
131       end;
132 
133       call picture_info_ ((picv), addr (buff), code);
134                                         /* let PL/I routine process it       */
135       if (code ^= 0)                    /* Oh,                               */
136       then do;                          /* ...you didnt like that one!       */
137          call error (0, me,
138             "^[Normalized picture > 64 char" ||
139             "^;Scale factor not in range -128:+127" ||
140             "^;Syntax error^]. ^a",
141             sign (code - 434) + 2,      /* That's right, they return a FUNNY */
142             the_picture);               /*  code!                            */
143          return;
144       end;
145       do argno = 2 to argct while (^strip_sw);
146          call arg_ptr (argno, argp, argl, code);
147          if (arg = "-strip")
148          then strip_sw = "1"b;
149       end;
150 
151       on condition (conversion)         /* just in case he blows it          */
152          begin;
153             Cond = "Conversion";
154             goto err_exit;
155          end;
156       on condition (size)               /* just in case he blows it          */
157          begin;
158             Cond = "Size";
159             goto err_exit;
160          end;
161       do argno = 2 to argct;
162          call arg_ptr (argno, argp, argl, code);
163          if (arg ^= "-strip")
164          then do;
165 
166 /* let somebody do it who UNDERSTANDS all these things                       */
167             temp_length = addr (buff) -> picture_image.prec
168                + 262144 * (addr (buff) -> picture_image.scale
169                - addr (buff) -> picture_image.scalefactor);
170 
171             call assign_ (addr (temp),
172                map_type (addr (buff) -> picture_image.type),
173                temp_length, argp, 42, (argl));
174             call pack_picture_ (addr (target) -> bit1, buff, temp);
175 
176             if ^testing                 /* not valid_pictured_data           */
177             then do;
178                pictured
179                   = substr (target, 1, addr (buff) -> picture_image.varlength);
180                if strip_sw              /* should we dump the extras?        */
181                then do;
182                   pictured = ltrim (pictured);
183                   if (index (pictured, ".") ^= 0)
184                   then do;
185                      pictured = rtrim (pictured, "0");
186                      if (substr (pictured, length (pictured), 1) = ".")
187                      then pictured
188                              = substr (pictured, 1, length (pictured) - 1);
189                   end;
190                end;
191                if (retval_p = null ())
192                then call ioa_ ("^a", pictured);
193                else do;
194                   j = index (pictured, " ");
195                   if (length (retval) > 0)
196                   then retval = retval || " ";
197                   if (j > 0)
198                   then retval = retval || """";
199                   retval = retval || pictured;
200                   if (j > 0)
201                   then retval = retval || """";
202                end;
203             end;
204          end;
205       end;
206       if testing
207       then do;
208          if (retval_p = null ())        /* command?                          */
209          then call ioa_ ("true");       /* yes. print it                     */
210          else retval = "true";          /* no. return it                     */
211       end;
212 
213       return;
214 
215 err_exit:
216       if testing
217       then do;
218          if (retval_p = null ())        /* command?                          */
219          then call ioa_ ("false");      /* yes. print it                     */
220          else retval = "false";         /* no. return it                     */
221       end;
222       else call error (0, me,
223               "^a condition occurred while editing ""^a"" thru ""^a""",
224               Cond, arg, the_picture);
225       return;
226 
227 dcl active_fnc_err_ entry options (variable);
228 dcl arg             char (argl) based (argp);
229 dcl argct           fixed bin;
230 dcl argl            fixed bin (21);
231 dcl argno           fixed bin;
232 dcl argp            ptr;
233 dcl assign_         entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin,
234                     fixed bin (35));
235 dcl bit1            bit (1) unaligned based;
236 dcl buff            (20) fixed binary;
237 dcl code            fixed bin (35);
238 dcl Cond            char (12);
239 dcl com_err_        entry options (variable);
240 dcl conversion      condition;
241 dcl cu_$af_arg_count entry (fixed bin, fixed bin (35));
242 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
243 dcl arg_ptr         entry (fixed bin, ptr, fixed bin (21), fixed bin (35))
244                     automatic;
245 dcl cu_$arg_ptr     entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
246 dcl cu_$af_arg_ptr  entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
247 dcl error           entry options (variable) automatic;
248 dcl error_table_$noarg fixed bin (35) ext static;
249 dcl ioa_            entry options (variable);
250 dcl j               fixed bin;
251 dcl me              char (32);
252 dcl pack_picture_   options (variable);
253 dcl picl            fixed bin;
254 dcl picp            ptr;
255 dcl picture_info_   entry (char (*) aligned, ptr, fixed bin (35));
256 dcl pictured        char (256) var;
257 dcl picv            char (picl) based (picp);
258 dcl retval          char (retval_l) var based (retval_p);
259 dcl retval_l        fixed bin (21);
260 dcl retval_p        ptr;
261 dcl size            condition;
262 dcl strip_sw        bit (1);
263 dcl target          char (128);
264 dcl temp            (128) char (1) unaligned;
265 dcl temp_length     fixed bin (35);
266 dcl testing         bit (1);
267 dcl the_picture     char (100) var;
268 
269 dcl (addr, index, length, ltrim, null, rtrim, sign, substr) builtin;
270 
271 %include picture_image;
272 dcl map_type        (24:28) fixed bin int static init (
273                     42,                 /* character                         */
274                     18,                 /* real fixed dec                    */
275                     22,                 /* cplx fixed dec                    */
276                     20,                 /* real float dec                    */
277                     24);                /* cplx float dec                    */
278    end picture;