1 %;
  2 get_current_charges: gcc: proc;
  3 
  4 /* this procedure is used to print a brief summary of the charges for one or more
  5    designated users on a project.
  6    In addition to the project name and up to 20 user names, the following options may be
  7    specified (which apply to the entire invocation of the command):
  8    .      -limit    displays limits for each shift and total
  9    .      -attributes (-att)  displays some of the attributes specified for the user.
 10    .      -lastlog (-ll)  displays the time the user last logged in.
 11    .      -total (-tt) displays only totals (not shifts).
 12    .      -absolute (-abs) displays cutoff and absolute spent info.
 13 
 14    Initial coding:  JKlensin, 23 July 1973 (preliminary)
 15    Modified for better performance: jck 4 Dec 73
 16    Revised for AML, JKlensin, 18 February 1974
 17    */
 18 /* Copyright 1973 Massachusetts Institute of Technology */
 19 /* Revised 02/19/74 */
 20 
 21 /* declarations to pick up parameters */
 22 dcl  cu_$arg_count ext entry (fixed bin),
 23      cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
 24      nargs fixed bin,
 25      ai fixed bin,                                          /* argument index */
 26      ap ptr,                                                /* to argument */
 27      al fixed bin,                                          /* length of argument */
 28      err fixed bin (35),                                    /* error code */
 29      arg char (al) based (ap),                              /* to look at argument */
 30      argerr bit (1) aligned init ("0"b);                    /* used to indicate argument processing error */
 31 
 32 dcl  username (20) char (24) aligned,                       /* the list of usernames to be displayed (arbitrary limit 20) */
 33      usercount fixed bin init (0),                          /* the  number of users to be displayed */
 34      projname char (28) aligned init ("") varying,          /* the project for that user */
 35      pdtname char (32) aligned;                             /* the name of the pdt */
 36 
 37 dcl (limitflag,                                             /* on if listing limits */
 38      logflag,                                               /* on if listing last login time */
 39      totflag,                                               /* on if printing only totals */
 40      absflag,                                               /* on if dealing with abs spent/cutoff */
 41      attribflag) bit (1) aligned init ("0"b);               /* on if listing attributes */
 42 
 43 dcl  open_value float bin static internal init (1e37);      /* value corresponding to '$open' */
 44 
 45 /* the following structure is used in printing limits.  It must match exactly the format of
 46    the string returned by the call to ioa_$rsnnl at 'limit_print:' */
 47 dcl 1 ast aligned,                                          /* the output structure for 'limit' */
 48     (2 pd1 char (26) init (" "),                            /* blanks */
 49     2 dl char (8),                                          /* the 'dollar limit' */
 50     2 sl (4) char (6),                                      /* blank, shift limit */
 51     2 x29 char (29) init (" "),                             /* padding */
 52     2 q4 char (4),                                          /* quota */
 53     2 nlchar char (1) init ("
 54 ")) unaligned;                                              /* always ends in new line */
 55 dcl  ast_length fixed bin static internal init (92);        /* length of above in chars */
 56 dcl  blen fixed bin;                                        /* for ioa_$rsnnl */
 57                                                             /* rest of the line is not interesting */
 58 
 59 
 60 
 61 dcl  i fixed bin,
 62      j fixed bin,
 63      ii fixed bin,
 64      uc fixed bin;
 65 
 66 dcl  hcs_$initiate ext entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin (1),
 67      fixed bin (2), ptr, fixed bin (35)),
 68      hcs_$terminate_noname ext entry (ptr, fixed bin (35));
 69 
 70 dcl  hcs_$quota_get ext entry (char (*) aligned, fixed bin, fixed bin (35), fixed bin (35), /* to get quota info */
 71      fixed bin, fixed bin (1), fixed bin, fixed bin (35)),
 72      quota fixed bin,                                       /* the directory quota */
 73     (trp, tup) fixed bin (35),                              /* time-record product, last updated */
 74      infqcnt fixed bin,                                     /* inferior directories with terminal quotas */
 75      taccsw fixed bin (1),                                  /* terminal account switch */
 76      qused fixed bin,                                       /* used in this directory */
 77      qerr fixed bin (35);                                   /* error from get_quota */
 78 dcl  date_time_ entry (fixed bin (71), char (*)),           /* to convert time to characters */
 79      datestring char (16);                                  /* for the date */
 80 
 81 dcl  abs_lim char (6),                                      /* for absolute limit */
 82      abs_date char (8);                                     /* and absolute cutoff date */
 83 
 84 /* WARNING: next call reference is an SPS internal interface */
 85 dcl  format_attributes_ entry (ptr, char (300) varying),    /* to get attribute names */
 86      astring char (300) varying;                            /* the attributes */
 87 
 88 dcl  pdtp ptr,                                              /* to the PDT */
 89      pdtep ptr;                                             /* to a user entry in the pdt */
 90 
 91 %page;
 92 %include user_attributes;
 93 %page;
 94 %include pdt;
 95 %page;
 96 
 97 dcl  com_err_ ext entry options (variable),                 /* for error messages */
 98      ioa_$rsnnl ext entry options (variable),               /* for formatting output lines */
 99      ioa_ ext entry options (variable);                     /* for printing */
100 dcl  ios_$write_ptr entry (ptr, fixed bin, fixed bin);      /* basic printing routine */
101 dcl  error_table_$noarg fixed bin static external;
102 
103 
104 dcl  statechar char (1),                                    /* the 'state' of the user */
105      sumabs float bin,                                      /* sum of absentee dollars used */
106      sumio float bin;                                       /* sum of io daemon dollars used */
107 
108 
109 dcl  pname char (20) aligned init ("get_current_charges"),
110      argformat char (120) aligned varying init ("project useri ... -options-") static internal,
111      optionformat char (129) aligned varying init (" options are: -limit, -attributes, -total, -lastlog, -absolute")
112      static internal;
113 
114 dcl (addr, null, substr) builtin;
115 
116 /* end of declarations */
117 /* ^L */
118 
119 /* scan the arguments  */
120           call cu_$arg_count (nargs);
121           if nargs <2 then do;
122                call com_err_ (0, pname, "^a^/^-^a", argformat, optionformat);
123                return;
124           end;
125 
126 argloop:  do ai = 1 to nargs;
127                call cu_$arg_ptr (ai, ap, al, err);
128 
129                if arg = "-limit" then limitflag = "1"b;     /* mark listing limits */
130 
131                else if arg = "-attributes" | arg = "-att" then attribflag = "1"b;
132 
133                else if arg = "-lastlog" | arg = "-ll" then logflag = "1"b;
134 
135                else if arg = "-total" | arg = "-tt" then totflag = "1"b;
136 
137                else if arg = "-absolute" | arg = "-abs" then absflag = "1"b;
138 
139                else if substr (arg, 1, 1) = "-" then do;    /* check for option */
140                     argerr = "1"b;                          /* mark an error */
141                     call com_err_ (0, pname, "option ^R^a^B not recognized", arg);
142                end;
143 
144                else if projname = "" then                   /* no project assigned yet */
145                     projname = arg;                         /* assign one */
146 
147                else if usercount = 20 then                  /* too many user requests */
148                     call com_err_ (0, pname, "too many users specified, user ^R^a^B ignored", arg);
149 
150                else do;                                     /* assign another user  to list */
151                     usercount = usercount +1;               /* update count */
152                     username (usercount) = arg;             /* add the name */
153                end;
154 
155           end argloop;
156 
157           if argerr then return;                            /* if errors with arguments, exit */
158           if projname = " " then do;
159                call com_err_ (error_table_$noarg, pname, "projectname");
160                return;
161           end;
162           if usercount = 0 then do;
163                call com_err_ (error_table_$noarg, pname, "username");
164                return;
165           end;
166 
167 /* end of argument evaluation */
168 
169 /* find the pdt */
170           pdtname = projname || ".pdt";                     /* form the name of the pdt */
171           call hcs_$initiate (">system_control_1>pdt", pdtname, "", 0b, 0b, pdtp, err);
172           if pdtp = null () then do;
173                call com_err_ (err, pname, "^a", projname);
174                return;
175           end;
176 
177 /* now, scan to find the user */
178 userloop: do uc = 1 to usercount;                           /* scan for each user */
179                do i = 1 to pdt.current_size;                /* look through the pdt */
180 
181                     pdtep = addr (pdt.user (i));            /* find next user entry */
182                     if user.state = 0 then ;                /* free entry, ignore */
183                     else if user.person_id = username (uc) then
184 found:                   do;
185 
186 /* get the 'state' information */
187                          if user.state = 2 then statechar = "*";
188                          else if user.now_in > 0 then statechar = ">";
189                          else statechar = " ";
190 
191 /* now, get the time-charge data for him */
192                          sumabs, sumio = 0e0;               /* initialize sums */
193                          do ii = 1 to 4;                    /* number of absentee and io queues */
194                               sumabs = sumabs+user.absentee (ii).charge; /* add all absentee queues */
195                               sumio = sumio+user.iod (ii).charge; /* add all io queues */
196                          end;
197 
198 /* get the quota data */
199                          call hcs_$quota_get (user.home_dir, quota, trp, tup, infqcnt,
200                               taccsw, qused, qerr);
201                          if qerr ^= 0 then                  /* some error with quota */
202                               quota, taccsw, qused = 0;     /* set values to zero */
203 
204 /* print the results */
205                          if ^totflag then
206                               call ioa_ ("^1a^24a ^8.2f ^5.0f ^5.0f ^5.0f ^5.0f  abs=^5.0f  io=^5.0f  pages=^4d",
207                               statechar, user.person_id, user.dollar_charge,
208                               user.interactive (1).charge, user.interactive (2).charge, user.interactive (3).charge,
209                               user.interactive (4).charge,
210                               sumabs, sumio, qused);
211                          else
212                          call ioa_ ("^1a^24a ^8.2f", statechar, user.person_id, user.dollar_charge);
213 
214                          if limitflag then                  /* display limits */
215 limit_print:                  do;
216                               call get_limit (user.dollar_limit, 8, 2, ast.dl); /* get total limit */
217                               if ^totflag then do;
218                                    do j = 1 to 4;           /* cget each shift limit */
219                                         call get_limit (user.shift_limit (j), 5, 0, ast.sl (j)); /* format shifts */
220                                    end;
221                                    call ioa_$rsnnl ("^4d", ast.q4, blen, quota); /* get quota into chars */
222                                    call ios_$write_ptr (addr (ast), 0, ast_length); /* print it */
223                               end;
224                               else call ioa_ ("^26x^8a", ast.dl); /* print total (dollar) limit */
225                          end limit_print;
226 
227                          if absflag then                    /* display absolute spent and maybe cutoff */
228 absolute_print:               do;
229                               if ^limitflag then
230                                    call ioa_ ("^26x^a = ^6.0f", "absolute spent", absolute_spent);
231                               else do;
232                                    call get_limit (absolute_limit, 6, 0, abs_lim); /* find absolute limit */
233                                    call date_time_ (absolute_cutoff, abs_date); /* and date */
234                                    if absolute_increm = 0 then
235                                         call ioa_ ("^26xabsolute: spent= ^6.0f, limit = ^a, cutoff= ^a",
236                                         absolute_spent, abs_lim, abs_date);
237                                    else
238                                    call ioa_ ("^26xabsolute: spent= ^6.0f, limit = ^a, cutoff= ^a, reset=^d",
239                                         absolute_spent, abs_lim, abs_date, absolute_increm);
240                               end;
241                          end absolute_print;
242 
243                          if attribflag then                 /* display attributes */
244 attribute_print:              do;
245                               call format_attributes_ (addr (user.at), astring); /* turn attributes into string */
246                               call ioa_ ("^26x^a", astring); /* print them */
247                          end attribute_print;
248 
249                          if logflag then                    /* handle login info */
250 lastlog_print:                do;
251                               call date_time_ (user.last_login_time, datestring); /* convert time */
252                               call ioa_ ("^26xLast login at ^a from ^a", datestring, user.last_login_unit);
253                          end lastlog_print;
254 
255                          if qerr ^= 0 then
256                               call com_err_ (qerr, pname, user.home_dir); /* print 'bad quota values' message */
257 
258                          go to end_userloop;                /* go get next user */
259                     end found;
260 
261                end;
262                call com_err_ (0, pname, "user ^R^a^B not found", username (uc)); /* no user of this name */
263 end_userloop: end userloop;
264 
265 
266 /* terminate the pdt */
267           call hcs_$terminate_noname (pdtp, err);
268           return;
269 
270 get_limit: proc (lim, np, ndp, outs);
271 
272 /* this procedure is used to convert the limits to characters.  It returns the
273    special value '$open' when necessary.  */
274 dcl  lim float bin,                                         /* the limit */
275      np fixed bin,                                          /* the total number of places to be assigned */
276      ndp fixed bin,                                         /* the number of decimal places */
277      outs char (*);                                         /* the character string to be filled in */
278 dcl  bl fixed bin;                                          /* length used - not referenced */
279 dcl  length builtin;
280                if lim = open_value then                     /* handle 'open' (no limit) case */
281                     outs = " $open";                        /* set output */
282 
283                else call ioa_$rsnnl ("^v.vf", outs, bl, np, ndp, lim); /* convert */
284                return;
285 
286           end get_limit;
287 
288      end get_current_charges;