home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / misc / volume33 / mailagnt / part06 < prev    next >
Encoding:
Text File  |  1992-11-19  |  54.9 KB  |  1,875 lines
  1. Newsgroups: comp.sources.misc
  2. From: ram@eiffel.com (Raphael Manfredi)
  3. Subject:  v33i098:  mailagent - Rule Based Mail Filtering, Part06/17
  4. Message-ID: <1992Nov20.050425.13742@sparky.imd.sterling.com>
  5. X-Md4-Signature: e63b286cb79238712976aa42741a690e
  6. Date: Fri, 20 Nov 1992 05:04:25 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: ram@eiffel.com (Raphael Manfredi)
  10. Posting-number: Volume 33, Issue 98
  11. Archive-name: mailagent/part06
  12. Environment: Perl, Sendmail, UNIX
  13.  
  14. #! /bin/sh
  15. # This is a shell archive.  Remove anything before this line, then feed it
  16. # into a shell via "sh file" or similar.  To overwrite existing files,
  17. # type "sh file -c".
  18. # Contents:  agent/files/proglist agent/pl/getdate.pl agent/pl/stats.pl
  19. # Wrapped by kent@sparky on Wed Nov 18 22:42:22 1992
  20. PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin ; export PATH
  21. echo If this archive is complete, you will see the following message:
  22. echo '          "shar: End of archive 6 (of 17)."'
  23. if test -f 'agent/files/proglist' -a "${1}" != "-c" ; then 
  24.   echo shar: Will not clobber existing file \"'agent/files/proglist'\"
  25. else
  26.   echo shar: Extracting \"'agent/files/proglist'\" \(2060 characters\)
  27.   sed "s/^X//" >'agent/files/proglist' <<'END_OF_FILE'
  28. X# Small descriptions for programs
  29. X
  30. X* cshar
  31. XThe useful shell-archive maker. I modified the original
  32. Xslightly to add a Configure script.
  33. X---
  34. X
  35. X* kit
  36. XA simple binary tarmailer. This is used by the mail agent when
  37. Xmailing big sets of files. You presently need cshar (from
  38. XRich Salz) to use kit.
  39. X---
  40. X
  41. X* dist
  42. XLarry Wall's dist package, modified. It contains:
  43. X    - metaconfig, a Configure script generator
  44. X    - a patch generator
  45. X    - a distribution maker
  46. XIt comes from version Larry's dist 2.0 PL 2 package, but has
  47. Xquite a few extensions (I worked especially on the patch
  48. Xgenerating tools and metaconfig itself). The units used by
  49. Xmetaconfig have been manually ripped off from some recently
  50. Xposted Configure scripts (elm 2.3, perl 3.0).
  51. X---
  52. X
  53. X* matrix
  54. XAn object-oriented matrix library. It is a beta-test release.
  55. X---
  56. X
  57. X* file
  58. XThe file(1) command with lots of /etc/magic entries. Useful
  59. Xwhen you work with NFS on different architectures as you
  60. Xcan have your own magic file.
  61. X---
  62. X
  63. X* rcs
  64. XGNU Revision Control System. You need RCS to use Larry's
  65. Xdist package (patch generating tools).
  66. X---
  67. X
  68. X* cops
  69. XSecurity analysis tools. May be useful to find holes in
  70. Xyour system.
  71. X---
  72. X
  73. X* xfmt
  74. XSimple text formatter. You need flex to compile it.
  75. XIt looks like SUN-OS fmt program.
  76. X---
  77. X
  78. X* less
  79. XThe pager that is more than more(1).
  80. X---
  81. X
  82. X* flex
  83. XFast lex. Needed for the xfmt package, because lex is not
  84. Xpowerful enough.
  85. X---
  86. X
  87. X* et
  88. XError table compiler (from MIT).
  89. X---
  90. X
  91. X* undel
  92. XReplacement for rm(1). Marks files for deletion instead of
  93. Xremoving them. You need the et package for version 2.0 to
  94. Xcompile.
  95. X---
  96. X
  97. X* dither
  98. XDisplays a color image on a two-level display (White and black).
  99. XUses a non-standard picture format in input and output
  100. X(that's mine ! :-)).
  101. X---
  102. X
  103. X* perl
  104. XLarry Wall's Practical Extraction and Report Language. It
  105. Xcombines the best features of C, awk, sed and sh.
  106. XYou need it to use the dist package.
  107. X---
  108. X
  109. X* patch
  110. XThe useful utility to apply diff files on a distribution. You could
  111. Xof course apply them by hand, but it may well be a long procedure !
  112. XWritten by Larry Wall.
  113. X---
  114. END_OF_FILE
  115.   if test 2060 -ne `wc -c <'agent/files/proglist'`; then
  116.     echo shar: \"'agent/files/proglist'\" unpacked with wrong size!
  117.   fi
  118.   # end of 'agent/files/proglist'
  119. fi
  120. if test -f 'agent/pl/getdate.pl' -a "${1}" != "-c" ; then 
  121.   echo shar: Will not clobber existing file \"'agent/pl/getdate.pl'\"
  122. else
  123.   echo shar: Extracting \"'agent/pl/getdate.pl'\" \(26463 characters\)
  124.   sed "s/^X//" >'agent/pl/getdate.pl' <<'END_OF_FILE'
  125. X;# From: rick@imd.sterling.com (Richard Ohnemus)
  126. X;# Newsgroups: comp.lang.perl
  127. X;# Subject: Re: Parsing a date/time string
  128. X;# Message-ID: <1992Jun26.133036.2077@sparky.imd.sterling.com>
  129. X;# Date: 26 Jun 92 13:30:36 GMT
  130. X;# References: <25116@life.ai.mit.edu>
  131. X;# Sender: news@sparky.imd.sterling.com (News Admin)
  132. X;# Organization: Sterling Software, IMD
  133. X;#
  134. X;# Here is the famous (or infamous) getdate routine adapted for use with
  135. X;# PERL. (This was a quick hack but, it is being used in a couple of
  136. X;# programs and no problems have shown up yet. 8-{)
  137. X;# 
  138. X;# Calling sequence:
  139. X;#   $seconds = &getdate($date_time_str, 
  140. X;#                       $time_in_seconds, 
  141. X;#                       $offset_from_GMT_in_minutes);
  142. X;# 
  143. X;# time_in_seconds and offset_from_GMT_in_minutes are optional arguments.
  144. X;# If time_in_seconds is not specified then the current time is used.
  145. X;# If offset_from_GMT_in_minutes is not specified then TZ is read from the
  146. X;# environment to get the offset.
  147. X;# 
  148. X;# Examples of use:
  149. X;#   require 'getdate.pl';
  150. X;#   seconds = &getdate('Apr 24 17:44');
  151. X;#   seconds = &getdate('2 Feb 1992 03:53:17');
  152. X;#   ... many more date/time formats supported ...
  153. X;#
  154. X;# getdate.pl was generated from getdate.y by a version of Berkeley Yacc
  155. X;# 1.8 that I modified to generate PERL output. (The patches are based on
  156. X;# Ray Lischner's patches to byacc 1.6.) If anyone would like a copy of
  157. X;# the patches I can e-mail them or make them available for anonymous FTP
  158. X;# if there is enough interest.
  159. X;#
  160. X;#
  161. X;# $yysccsid = "@(#)yaccpar    1.8 (Berkeley) 01/20/91 (Perl 2.0 04/23/92)";
  162. X;#     Steven M. Bellovin (unc!smb)
  163. X;#    Dept. of Computer Science
  164. X;#    University of North Carolina at Chapel Hill
  165. X;#    @(#)getdate.y    2.13    9/16/86
  166. X;#
  167. X;#    Richard J. Ohnemus (rick@IMD.Sterling.COM)
  168. X;#    (Where do I work??? I'm not even sure who I am! 8-{)
  169. X;#    converted to PERL 4/24/92
  170. X;#
  171. X;# Below are logging information for this package as included in the
  172. X;# mailagent program.
  173. X;#
  174. X;# $Id: getdate.pl,v 2.9.1.1 92/07/25 12:39:08 ram Exp $
  175. X;#
  176. X;# $Log:    getdate.pl,v $
  177. X;# Revision 2.9.1.1  92/07/25  12:39:08  ram
  178. X;# patch1: swapped offsets for EET and WET (reported by Jost Krieger)
  179. X;# 
  180. Xpackage getdate;
  181. X
  182. X# This package parses a date string and converts it into a number of seconds.
  183. X# I did minor editing on this code, mainly to remove all the YYDEBUG #if tests
  184. X# and to reformat some of the table. I also encapsulated all the initializations
  185. X# into init subroutines and reworked on the indentation of semantic actions.
  186. X# Oh yes, I also made some minor modifications in place (i.e. without running
  187. X# yacc again) to apply some small fixes Richard sent me via e-mail.
  188. X# Other than that, it's pretty verbatim--RAM.
  189. X
  190. Xsub yyinit {
  191. X    $daysec = 24 * 60 * 60;
  192. X
  193. X    $AM = 1;
  194. X    $PM = 2;
  195. X    $DAYLIGHT = 1;
  196. X    $STANDARD = 2;
  197. X    $MAYBE = 3;
  198. X
  199. X    $ID=257;
  200. X    $MONTH=258;
  201. X    $DAY=259;
  202. X    $MERIDIAN=260;
  203. X    $NUMBER=261;
  204. X    $UNIT=262;
  205. X    $MUNIT=263;
  206. X    $SUNIT=264;
  207. X    $ZONE=265;
  208. X    $DAYZONE=266;
  209. X    $AGO=267;
  210. X    $YYERRCODE=256;
  211. X    @yylhs = (                                               -1,
  212. X        0,    0,    1,    1,    1,    1,    1,    1,    7,    2,
  213. X        2,    2,    2,    2,    2,    2,    3,    3,    5,    5,
  214. X        5,    4,    4,    4,    4,    4,    4,    4,    4,    4,
  215. X        6,    6,    6,    6,    6,    6,    6,
  216. X    );
  217. X    @yylen = (                                                2,
  218. X        0,    2,    1,    1,    1,    1,    1,    1,    1,    2,
  219. X        3,    4,    4,    5,    6,    6,    1,    1,    1,    2,
  220. X        2,    3,    5,    2,    4,    5,    7,    3,    2,    3,
  221. X        2,    2,    2,    1,    1,    1,    2,
  222. X    );
  223. X    @yydefred = (                                             1,
  224. X        0,    0,    0,    0,   34,   35,   36,   17,   18,    2,
  225. X        3,    4,    5,    6,    0,    8,    0,   20,    0,   21,
  226. X       10,   31,   32,   33,    0,    0,   37,    0,    0,   30,
  227. X        0,    0,    0,   25,   12,   13,    0,    0,    0,    0,
  228. X       23,    0,   15,   16,   27,
  229. X    );
  230. X    @yydgoto = (                                              1,
  231. X       10,   11,   12,   13,   14,   15,   16,
  232. X    );
  233. X    @yysindex = (                                             0,
  234. X     -241, -255,  -37,  -47,    0,    0,    0,    0,    0,    0,
  235. X        0,    0,    0,    0, -259,    0,  -42,    0, -252,    0,
  236. X        0,    0,    0,    0, -249, -248,    0,  -44, -246,    0,
  237. X      -55,  -31, -235,    0,    0,    0, -234, -232,  -28, -256,
  238. X        0, -230,    0,    0,    0,
  239. X    );
  240. X    @yyrindex = (                                             0,
  241. X        0,    0,    1,   79,    0,    0,    0,    0,    0,    0,
  242. X        0,    0,    0,    0,   10,    0,   46,    0,   55,    0,
  243. X        0,    0,    0,    0,    0,    0,    0,   19,    0,    0,
  244. X       64,   28,    0,    0,    0,    0,    0,    0,   37,   73,
  245. X        0,    0,    0,    0,    0,
  246. X    );
  247. X    @yygindex = (                                             0,
  248. X        0,    0,    0,    0,    0,    0,    0,
  249. X    );
  250. X    $YYTABLESIZE=345;
  251. X    @yytable = (                                             26,
  252. X       19,   29,   37,   43,   44,   17,   18,   27,   30,    7,
  253. X       25,   31,   32,   33,   34,   38,    2,    3,   28,    4,
  254. X        5,    6,    7,    8,    9,   39,   40,   22,   41,   42,
  255. X       45,    0,    0,    0,    0,    0,   26,    0,    0,    0,
  256. X        0,    0,    0,    0,    0,   24,    0,    0,    0,    0,
  257. X        0,    0,    0,    0,   29,    0,    0,    0,    0,    0,
  258. X        0,    0,    0,   11,    0,    0,    0,    0,    0,    0,
  259. X        0,    0,   14,    0,    0,    0,    0,    0,    9,    0,
  260. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  261. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  262. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  263. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  264. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  265. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  266. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  267. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  268. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  269. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  270. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  271. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  272. X        0,    0,    0,    0,   35,   36,    0,    0,    0,    0,
  273. X       19,   20,   21,    0,   22,   23,   24,    0,   28,    0,
  274. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  275. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  276. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  277. X        0,    0,    0,    0,    0,    0,    0,    0,   19,   19,
  278. X        0,   19,   19,   19,   19,   19,   19,    7,    7,    0,
  279. X        7,    7,    7,    7,    7,    7,   28,   28,    0,   28,
  280. X       28,   28,   28,   28,   28,   22,   22,    0,   22,   22,
  281. X       22,   22,   22,   22,   26,   26,    0,   26,   26,   26,
  282. X       26,   26,   26,   24,   24,    0,    0,   24,   24,   24,
  283. X       24,   24,   29,   29,    0,    0,   29,   29,   29,   29,
  284. X       29,   11,   11,    0,    0,   11,   11,   11,   11,   11,
  285. X       14,   14,    0,    0,   14,   14,   14,   14,   14,    9,
  286. X        0,    0,    0,    9,    9,
  287. X    );
  288. X    @yycheck = (                                             47,
  289. X        0,   44,   58,  260,  261,  261,   44,  267,  261,    0,
  290. X       58,  261,  261,   58,  261,   47,  258,  259,    0,  261,
  291. X      262,  263,  264,  265,  266,  261,  261,    0,  261,   58,
  292. X      261,   -1,   -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,
  293. X       -1,   -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,
  294. X       -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,
  295. X       -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,   -1,
  296. X       -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,    0,   -1,
  297. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  298. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  299. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  300. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  301. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  302. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  303. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  304. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  305. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  306. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  307. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  308. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  309. X       -1,   -1,   -1,   -1,  260,  261,   -1,   -1,   -1,   -1,
  310. X      258,  259,  260,   -1,  262,  263,  264,   -1,  261,   -1,
  311. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  312. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  313. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  314. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  258,  259,
  315. X       -1,  261,  262,  263,  264,  265,  266,  258,  259,   -1,
  316. X      261,  262,  263,  264,  265,  266,  258,  259,   -1,  261,
  317. X      262,  263,  264,  265,  266,  258,  259,   -1,  261,  262,
  318. X      263,  264,  265,  266,  258,  259,   -1,  261,  262,  263,
  319. X      264,  265,  266,  258,  259,   -1,   -1,  262,  263,  264,
  320. X      265,  266,  258,  259,   -1,   -1,  262,  263,  264,  265,
  321. X      266,  258,  259,   -1,   -1,  262,  263,  264,  265,  266,
  322. X      258,  259,   -1,   -1,  262,  263,  264,  265,  266,  261,
  323. X       -1,   -1,   -1,  265,  266,
  324. X    );
  325. X    $YYFINAL=1;
  326. X    $YYSTACKSIZE = $YYSTACKSIZE || $YYMAXDEPTH || 500;
  327. X    $YYMAXDEPTH = $YYMAXDEPTH || $YYSTACKSIZE || 500;
  328. X    $yyss[$YYSTACKSIZE] = 0;
  329. X    $yyvs[$YYSTACKSIZE] = 0;
  330. X}
  331. X
  332. Xsub yyclearin { $yychar = -1; }
  333. Xsub yyerrok { $yyerrflag = 0; }
  334. Xsub YYERROR { ++$yynerrs; &yy_err_recover; }
  335. Xsub yy_err_recover {
  336. X  if ($yyerrflag < 3)
  337. X  {
  338. X    $yyerrflag = 3;
  339. X    while (1)
  340. X    {
  341. X      if (($yyn = $yysindex[$yyss[$yyssp]]) && 
  342. X          ($yyn += $YYERRCODE) >= 0 && 
  343. X          $yycheck[$yyn] == $YYERRCODE)
  344. X      {
  345. X        $yyss[++$yyssp] = $yystate = $yytable[$yyn];
  346. X        $yyvs[++$yyvsp] = $yylval;
  347. X        next yyloop;
  348. X      }
  349. X      else
  350. X      {
  351. X        return(1) if $yyssp <= 0;
  352. X        --$yyssp;
  353. X        --$yyvsp;
  354. X      }
  355. X    }
  356. X  }
  357. X  else
  358. X  {
  359. X    return (1) if $yychar == 0;
  360. X    $yychar = -1;
  361. X    next yyloop;
  362. X  }
  363. X0;
  364. X} # yy_err_recover
  365. X
  366. Xsub yyparse {
  367. X  $yynerrs = 0;
  368. X  $yyerrflag = 0;
  369. X  $yychar = (-1);
  370. X
  371. X  $yyssp = 0;
  372. X  $yyvsp = 0;
  373. X  $yyss[$yyssp] = $yystate = 0;
  374. X
  375. Xyyloop: while(1)
  376. X  {
  377. X    yyreduce: {
  378. X      last yyreduce if ($yyn = $yydefred[$yystate]);
  379. X      if ($yychar < 0)
  380. X      {
  381. X        if (($yychar = &yylex) < 0) { $yychar = 0; }
  382. X      }
  383. X      if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 &&
  384. X              $yycheck[$yyn] == $yychar)
  385. X      {
  386. X        $yyss[++$yyssp] = $yystate = $yytable[$yyn];
  387. X        $yyvs[++$yyvsp] = $yylval;
  388. X        $yychar = (-1);
  389. X        --$yyerrflag if $yyerrflag > 0;
  390. X        next yyloop;
  391. X      }
  392. X      if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 &&
  393. X            $yycheck[$yyn] == $yychar)
  394. X      {
  395. X        $yyn = $yytable[$yyn];
  396. X        last yyreduce;
  397. X      }
  398. X      if (! $yyerrflag) {
  399. X        &yyerror('syntax error');
  400. X        ++$yynerrs;
  401. X      }
  402. X      return(1) if &yy_err_recover;
  403. X    } # yyreduce
  404. X    $yym = $yylen[$yyn];
  405. X    $yyval = $yyvs[$yyvsp+1-$yym];
  406. X    switch:
  407. X    {
  408. X        if ($yyn == 3) {
  409. X            $timeflag++;
  410. X            last switch;
  411. X        }
  412. X        if ($yyn == 4) {
  413. X            $zoneflag++;
  414. X            last switch;
  415. X        }
  416. X        if ($yyn == 5) {
  417. X            $dateflag++;
  418. X            last switch;
  419. X        }
  420. X        if ($yyn == 6) {
  421. X            $dayflag++;
  422. X            last switch;
  423. X        }
  424. X        if ($yyn == 7) {
  425. X            $relflag++;
  426. X            last switch;
  427. X        }
  428. X        if ($yyn == 9) {
  429. X            if ($timeflag && $dateflag && !$relflag) {
  430. X                $year = $yyvs[$yyvsp-0];
  431. X            }
  432. X            else {
  433. X                $timeflag++;
  434. X                $hh = int($yyvs[$yyvsp-0] / 100);
  435. X                $mm = $yyvs[$yyvsp-0] % 100;
  436. X                $ss = 0;
  437. X                $merid = 24;
  438. X            }
  439. X            last switch;
  440. X        }
  441. X        if ($yyn == 10) {
  442. X            $hh = $yyvs[$yyvsp-1];
  443. X            $mm = 0;
  444. X            $ss = 0;
  445. X            $merid = $yyvs[$yyvsp-0];
  446. X            last switch;
  447. X        }
  448. X        if ($yyn == 11) {
  449. X            $hh = $yyvs[$yyvsp-2];
  450. X            $mm = $yyvs[$yyvsp-0];
  451. X            $merid = 24;
  452. X            last switch;
  453. X        }
  454. X        if ($yyn == 12) {
  455. X            $hh = $yyvs[$yyvsp-3];
  456. X            $mm = $yyvs[$yyvsp-1];
  457. X            $merid = $yyvs[$yyvsp-0];
  458. X            last switch;
  459. X        }
  460. X        if ($yyn == 13) {
  461. X            $hh = $yyvs[$yyvsp-3];
  462. X            $mm = $yyvs[$yyvsp-1];
  463. X            $merid = 24;
  464. X            $daylight = $STANDARD;
  465. X            $ourzone = $yyvs[$yyvsp-0] % 100 + 60 * int($yyvs[$yyvsp-0] / 100);
  466. X            last switch;
  467. X        }
  468. X        if ($yyn == 14) {
  469. X            $hh = $yyvs[$yyvsp-4];
  470. X            $mm = $yyvs[$yyvsp-2];
  471. X            $ss = $yyvs[$yyvsp-0];
  472. X            $merid = 24;
  473. X            last switch;
  474. X        }
  475. X        if ($yyn == 15) {
  476. X            $hh = $yyvs[$yyvsp-5];
  477. X            $mm = $yyvs[$yyvsp-3];
  478. X            $ss = $yyvs[$yyvsp-1];
  479. X            $merid = $yyvs[$yyvsp-0];
  480. X            last switch;
  481. X        }
  482. X        if ($yyn == 16) {
  483. X            $hh = $yyvs[$yyvsp-5];
  484. X            $mm = $yyvs[$yyvsp-3];
  485. X            $ss = $yyvs[$yyvsp-1];
  486. X            $merid = 24;
  487. X            $daylight = $STANDARD;
  488. X            $ourzone = $yyvs[$yyvsp-0] % 100 + 60 * int($yyvs[$yyvsp-0] / 100);
  489. X            last switch;
  490. X        }
  491. X        if ($yyn == 17) {
  492. X            $ourzone = $yyvs[$yyvsp-0];
  493. X            $daylight = $STANDARD;
  494. X            last switch;
  495. X        }
  496. X        if ($yyn == 18) {
  497. X            $ourzone = $yyvs[$yyvsp-0];
  498. X            $daylight = $DAYLIGHT;
  499. X            last switch;
  500. X        }
  501. X        if ($yyn == 19) {
  502. X            $dayord = 1;
  503. X            $dayreq = $yyvs[$yyvsp-0];
  504. X            last switch;
  505. X        }
  506. X        if ($yyn == 20) {
  507. X            $dayord = 1;
  508. X            $dayreq = $yyvs[$yyvsp-1];
  509. X            last switch;
  510. X        }
  511. X        if ($yyn == 21) {
  512. X            $dayord = $yyvs[$yyvsp-1];
  513. X            $dayreq = $yyvs[$yyvsp-0];
  514. X            last switch;
  515. X        }
  516. X        if ($yyn == 22) {
  517. X            $month = $yyvs[$yyvsp-2];
  518. X            $day = $yyvs[$yyvsp-0];
  519. X            last switch;
  520. X        }
  521. X        if ($yyn == 23) {
  522. X            #
  523. X            # HACK ALERT!!!!
  524. X            # The 1000 is a magic number to attempt to force
  525. X            # use of 4 digit years if year/month/day can be
  526. X            # parsed. This was only done for backwards
  527. X            # compatibility in rh.
  528. X            #
  529. X            if ($yyvs[$yyvsp-4] > 1000) {
  530. X                $year = $yyvs[$yyvsp-4];
  531. X                $month = $yyvs[$yyvsp-2];
  532. X                $day = $yyvs[$yyvsp-0];
  533. X            }
  534. X            else {
  535. X                $month = $yyvs[$yyvsp-4];
  536. X                $day = $yyvs[$yyvsp-2];
  537. X                $year = $yyvs[$yyvsp-0];
  538. X            }
  539. X            last switch;
  540. X        }
  541. X        if ($yyn == 24) {
  542. X            $month = $yyvs[$yyvsp-1];
  543. X            $day = $yyvs[$yyvsp-0];
  544. X            last switch;
  545. X        }
  546. X        if ($yyn == 25) {
  547. X            $month = $yyvs[$yyvsp-3];
  548. X            $day = $yyvs[$yyvsp-2];
  549. X            $year = $yyvs[$yyvsp-0];
  550. X            last switch;
  551. X        }
  552. X        if ($yyn == 26) {
  553. X            $month = $yyvs[$yyvsp-4];
  554. X            $day = $yyvs[$yyvsp-3];
  555. X            $hh = $yyvs[$yyvsp-2];
  556. X            $mm = $yyvs[$yyvsp-0];
  557. X            $merid = 24;
  558. X            $timeflag++;
  559. X            last switch;
  560. X        }
  561. X        if ($yyn == 27) {
  562. X            $month = $yyvs[$yyvsp-6];
  563. X            $day = $yyvs[$yyvsp-5];
  564. X            $hh = $yyvs[$yyvsp-4];
  565. X            $mm = $yyvs[$yyvsp-2];
  566. X            $ss = $yyvs[$yyvsp-0];
  567. X            $merid = 24;
  568. X            $timeflag++;
  569. X            last switch;
  570. X        }
  571. X        if ($yyn == 28) {
  572. X            $month = $yyvs[$yyvsp-2];
  573. X            $day = $yyvs[$yyvsp-1];
  574. X            $year = $yyvs[$yyvsp-0];
  575. X            last switch;
  576. X        }
  577. X        if ($yyn == 29) {
  578. X            $month = $yyvs[$yyvsp-0];
  579. X            $day = $yyvs[$yyvsp-1];
  580. X            last switch;
  581. X        }
  582. X        if ($yyn == 30) {
  583. X            $month = $yyvs[$yyvsp-1];
  584. X            $day = $yyvs[$yyvsp-2];
  585. X            $year = $yyvs[$yyvsp-0];
  586. X            last switch;
  587. X        }
  588. X        if ($yyn == 31) {
  589. X            $relsec +=  60 * $yyvs[$yyvsp-1] * $yyvs[$yyvsp-0];
  590. X            last switch;
  591. X        }
  592. X        if ($yyn == 32) {
  593. X            $relmonth += $yyvs[$yyvsp-1] * $yyvs[$yyvsp-0];
  594. X            last switch;
  595. X        }
  596. X        if ($yyn == 33) {
  597. X            $relsec += $yyvs[$yyvsp-1];
  598. X            last switch;
  599. X        }
  600. X        if ($yyn == 34) {
  601. X            $relsec +=  60 * $yyvs[$yyvsp-0];
  602. X            last switch;
  603. X        }
  604. X        if ($yyn == 35) {
  605. X            $relmonth += $yyvs[$yyvsp-0];
  606. X            last switch;
  607. X        }
  608. X        if ($yyn == 36) {
  609. X            $relsec++;
  610. X            last switch;
  611. X        }
  612. X        if ($yyn == 37) {
  613. X            $relsec = -$relsec;
  614. X            $relmonth = -$relmonth;
  615. X            last switch;
  616. X        }
  617. X    } # switch
  618. X    $yyssp -= $yym;
  619. X    $yystate = $yyss[$yyssp];
  620. X    $yyvsp -= $yym;
  621. X    $yym = $yylhs[$yyn];
  622. X    if ($yystate == 0 && $yym == 0) {
  623. X      $yystate = $YYFINAL;
  624. X      $yyss[++$yyssp] = $YYFINAL;
  625. X      $yyvs[++$yyvsp] = $yyval;
  626. X      if ($yychar < 0) {
  627. X        if (($yychar = &yylex) < 0) { $yychar = 0; }
  628. X      }
  629. X      return(0) if $yychar == 0;
  630. X      next yyloop;
  631. X    }
  632. X    if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 &&
  633. X        $yyn <= $#yycheck && $yycheck[$yyn] == $yystate)
  634. X    {
  635. X        $yystate = $yytable[$yyn];
  636. X    } else {
  637. X        $yystate = $yydgoto[$yym];
  638. X    }
  639. X    $yyss[++$yyssp] = $yystate;
  640. X    $yyvs[++$yyvsp] = $yyval;
  641. X  } # yyloop
  642. X} # yyparse
  643. X
  644. Xsub dateconv {
  645. X    local($mm, $dd, $yy, $h, $m, $s, $mer, $zone, $dayflag) = @_;
  646. X    local($time_of_day, $jdate);
  647. X    local($i);
  648. X
  649. X    if ($yy < 0) {
  650. X        $yy = -$yy;
  651. X    }
  652. X    if ($yy < 100) {
  653. X        $yy += 1900;
  654. X    }
  655. X    $mdays[1] =
  656. X        28 + (($yy % 4) == 0 && (($yy % 100) != 0 || ($yy % 400) == 0));
  657. X    if ($yy < $epoch || $yy > 2001 || $mm < 1 || $mm > 12
  658. X        || $dd < 1 || $dd > $mdays[--$mm]) {
  659. X        return -1;
  660. X    }
  661. X    $jdate = $dd - 1;
  662. X    for ($i = 0; $i < $mm; $i++) {
  663. X        $jdate += $mdays[$i];
  664. X    }
  665. X    for ($i = $epoch; $i < $yy; $i++) {
  666. X        $jdate += 365 + (($i % 4) == 0);
  667. X    }
  668. X    $jdate *= $daysec;
  669. X    $jdate += $zone * 60;
  670. X    if (($time_of_day = &timeconv($h, $m, $s, $mer)) < 0) {
  671. X        return -1;
  672. X    }
  673. X    $jdate += $time_of_day;
  674. X    if ($dayflag == $DAYLIGHT
  675. X        || ($dayflag == $MAYBE && (localtime($jdate))[8])) {
  676. X        $jdate -= 60 * 60;
  677. X    }
  678. X    return $jdate;
  679. X}
  680. X
  681. Xsub dayconv {
  682. X    local($ordday, $day, $now) = @_;
  683. X    local(@loctime);
  684. X    local($time_of_day);
  685. X
  686. X    $time_of_day = $now;
  687. X    @loctime = localtime($time_of_day);
  688. X    $time_of_day += $daysec * (($day - $loctime[6] + 7) % 7);
  689. X    $time_of_day += 7 * $daysec * ($ordday <= 0 ? $ordday : $ordday - 1);
  690. X    return &daylcorr($time_of_day, $now);
  691. X}
  692. X
  693. Xsub timeconv {
  694. X    local($hh, $mm, $ss, $mer) = @_;
  695. X
  696. X    return -1 if ($mm < 0 || $mm > 59 || $ss < 0 || $ss > 59);
  697. X
  698. X    if ($mer == $AM) {
  699. X        return -1 if ($hh < 1 || $hh > 12);
  700. X        return 60 * (($hh % 12) * 60 + $mm) + $ss;
  701. X    }
  702. X    if ($mer == $PM) {
  703. X        return -1 if ($hh < 1 || $hh > 12);
  704. X        return 60 * (($hh % 12 + 12) * 60 + $mm) + $ss;
  705. X    }
  706. X    if ($mer == 24) {
  707. X        return -1 if ($hh < 0 || $hh > 23);
  708. X        return 60 * ($hh * 60 + $mm) + $ss;
  709. X    }
  710. X    return -1;
  711. X}
  712. X
  713. Xsub monthadd {
  714. X    local($sdate, $relmonth) = @_;
  715. X    local(@ltime);
  716. X    local($mm, $yy);
  717. X    
  718. X    return 0 if ($relmonth == 0);
  719. X
  720. X    @ltime = localtime($sdate);
  721. X    $mm = 12 * $ltime[5] + $ltime[4] + $relmonth;
  722. X    $yy = int($mm / 12);
  723. X    $mm = $mm % 12 + 1;
  724. X    return &daylcorr(&dateconv($mm, $ltime[3], $yy, $ltime[2],
  725. X                               $ltime[1], $ltime[0], 24, $ourzone, $MAYBE),
  726. X                     $sdate);
  727. X}
  728. X
  729. Xsub daylcorr {
  730. X    local($future, $now) = @_;
  731. X    local($fdayl, $nowdayl);
  732. X
  733. X    $nowdayl = ((localtime($now))[2] + 1) % 24;
  734. X    $fdayl = ((localtime($future))[2] + 1) % 24;
  735. X    return ($future - $now) + 60 * 60 * ($nowdayl - $fdayl);
  736. X}
  737. X
  738. Xsub yylex {
  739. X    local($pcnt, $sign);
  740. X
  741. X    while (1) {
  742. X        $dtstr =~ s/^\s*//;
  743. X        
  744. X        if ($dtstr =~ /^([-+])/) {
  745. X            $sign = ($1 eq '-') ? -1 : 1;
  746. X            $dtstr =~ s/^.\s*//;
  747. X            if ($dtstr =~ /^(\d+)/) {
  748. X                $yylval = eval "$1 * $sign";
  749. X                $dtstr =~ s/^\d+//;
  750. X                return $NUMBER;
  751. X            }
  752. X            else {
  753. X                return &yylex;
  754. X            }
  755. X        }
  756. X        elsif ($dtstr =~ /^(\d+)/) {
  757. X            $yylval = eval "$1";
  758. X            $dtstr =~ s/^\d+//;
  759. X            return $NUMBER;
  760. X        }
  761. X        elsif ($dtstr =~ /^([a-zA-z][a-zA-Z.]*)/) {
  762. X            $dtstr = substr($dtstr, length($1));
  763. X            return &lookup($1);
  764. X        }
  765. X        elsif ($dtstr =~ /^\(/) {
  766. X            $pcnt = 0;
  767. X            do {
  768. X                $dtstr = s/^(.)//;
  769. X                return 0 if !defined($1);
  770. X                $pcnt++ if ($1 eq '(');
  771. X                $pcnt-- if ($1 eq ')');
  772. X            } while ($pcnt > 0);
  773. X        }
  774. X        else {
  775. X            $yylval = ord(substr($dtstr, 0, 1));
  776. X            $dtstr =~ s/^.//;
  777. X            return $yylval;
  778. X        }
  779. X    }
  780. X}
  781. X        
  782. Xsub lookup_init {
  783. X    %mdtab = (
  784. X        "January",        "$MONTH,1",
  785. X        "February",        "$MONTH,2",
  786. X        "March",        "$MONTH,3",
  787. X        "April",        "$MONTH,4",
  788. X        "May",            "$MONTH,5",
  789. X        "June",            "$MONTH,6",
  790. X        "July",            "$MONTH,7",
  791. X        "August",        "$MONTH,8",
  792. X        "September",    "$MONTH,9",
  793. X        "Sept",            "$MONTH,9",
  794. X        "October",        "$MONTH,10",
  795. X        "November",        "$MONTH,11",
  796. X        "December",        "$MONTH,12",
  797. X
  798. X        "Sunday",        "$DAY,0",
  799. X        "Monday",        "$DAY,1",
  800. X        "Tuesday",        "$DAY,2",
  801. X        "Tues",            "$DAY,2",
  802. X        "Wednesday",    "$DAY,3",
  803. X        "Wednes",        "$DAY,3",
  804. X        "Thursday",        "$DAY,4",
  805. X        "Thur",            "$DAY,4",
  806. X        "Thurs",        "$DAY,4",
  807. X        "Friday",        "$DAY,5",
  808. X        "Saturday",        "$DAY,6"
  809. X    );
  810. X
  811. X    $HRS='*60';
  812. X    $HALFHR='30';
  813. X
  814. X    %mztab = (
  815. X        "a.m.",        "$MERIDIAN,$AM",
  816. X        "am",        "$MERIDIAN,$AM",
  817. X        "p.m.",        "$MERIDIAN,$PM",
  818. X        "pm",        "$MERIDIAN,$PM",
  819. X        "nst",        "$ZONE,3 $HRS + $HALFHR",        # Newfoundland
  820. X        "n.s.t.",    "$ZONE,3 $HRS + $HALFHR",
  821. X        "ast",        "$ZONE,4 $HRS",            # Atlantic
  822. X        "a.s.t.",    "$ZONE,4 $HRS",
  823. X        "adt",        "$DAYZONE,4 $HRS",
  824. X        "a.d.t.",    "$DAYZONE,4 $HRS",
  825. X        "est",        "$ZONE,5 $HRS",            # Eastern
  826. X        "e.s.t.",    "$ZONE,5 $HRS",
  827. X        "edt",        "$DAYZONE,5 $HRS",
  828. X        "e.d.t.",    "$DAYZONE,5 $HRS",
  829. X        "cst",        "$ZONE,6 $HRS",            # Central
  830. X        "c.s.t.",    "$ZONE,6 $HRS",
  831. X        "cdt",        "$DAYZONE,6 $HRS",
  832. X        "c.d.t.",    "$DAYZONE,6 $HRS",
  833. X        "mst",        "$ZONE,7 $HRS",            # Mountain
  834. X        "m.s.t.",    "$ZONE,7 $HRS",
  835. X        "mdt",        "$DAYZONE,7 $HRS",
  836. X        "m.d.t.",    "$DAYZONE,7 $HRS",
  837. X        "pst",        "$ZONE,8 $HRS",            # Pacific
  838. X        "p.s.t.",    "$ZONE,8 $HRS",
  839. X        "pdt",        "$DAYZONE,8 $HRS",
  840. X        "p.d.t.",    "$DAYZONE,8 $HRS",
  841. X        "yst",        "$ZONE,9 $HRS",            # Yukon
  842. X        "y.s.t.",    "$ZONE,9 $HRS",
  843. X        "ydt",        "$DAYZONE,9 $HRS",
  844. X        "y.d.t.",    "$DAYZONE,9 $HRS",
  845. X        "hst",        "$ZONE,10 $HRS",        # Hawaii
  846. X        "h.s.t.",    "$ZONE,10 $HRS",
  847. X        "hdt",        "$DAYZONE,10 $HRS",
  848. X        "h.d.t.",    "$DAYZONE,10 $HRS",
  849. X
  850. X        "gmt",        "$ZONE,0 $HRS",
  851. X        "g.m.t.",    "$ZONE,0 $HRS",
  852. X        "bst",        "$DAYZONE,0 $HRS",        # British Summer Time
  853. X        "b.s.t.",    "$DAYZONE,0 $HRS",
  854. X        "eet",        "$ZONE,-2 $HRS",        # European Eastern Time
  855. X        "e.e.t.",    "$ZONE,-2 $HRS",
  856. X        "eest",        "$DAYZONE,-2 $HRS",        # European Eastern Summer Time
  857. X        "e.e.s.t.",    "$DAYZONE,-2 $HRS",
  858. X        "met",        "$ZONE,-1 $HRS",        # Middle European Time
  859. X        "m.e.t.",    "$ZONE,-1 $HRS",
  860. X        "mest",        "$DAYZONE,-1 $HRS",        # Middle European Summer Time
  861. X        "m.e.s.t.",    "$DAYZONE,-1 $HRS",
  862. X        "wet",        "$ZONE,0 $HRS ",        # Western European Time
  863. X        "w.e.t.",    "$ZONE,0 $HRS ",
  864. X        "west",        "$DAYZONE,0 $HRS",        # Western European Summer Time
  865. X        "w.e.s.t.",    "$DAYZONE,0 $HRS",
  866. X
  867. X        "jst",        "$ZONE,-9 $HRS",        # Japan Standard Time
  868. X        "j.s.t.",    "$ZONE,-9 $HRS",        # Japan Standard Time
  869. X
  870. X        "aest",        "$ZONE,-10 $HRS",        # Australian Eastern Time
  871. X        "a.e.s.t.",    "$ZONE,-10 $HRS",
  872. X        "aesst",    "$DAYZONE,-10 $HRS",    # Australian Eastern Summer Time
  873. X        "a.e.s.s.t.",    "$DAYZONE,-10 $HRS",
  874. X        "acst",            "$ZONE,-(9 $HRS + $HALFHR)",    # Austr. Central Time
  875. X        "a.c.s.t.",        "$ZONE,-(9 $HRS + $HALFHR)",
  876. X        "acsst",        "$DAYZONE,-(9 $HRS + $HALFHR)",    # Austr. Central Summer
  877. X        "a.c.s.s.t.",    "$DAYZONE,-(9 $HRS + $HALFHR)",
  878. X        "awst",            "$ZONE,-8 $HRS",    # Australian Western Time
  879. X        "a.w.s.t.",        "$ZONE,-8 $HRS"        # (no daylight time there)
  880. X    );
  881. X
  882. X    %unittab = (
  883. X        "year",        "$MUNIT,12",
  884. X        "month",    "$MUNIT,1",
  885. X        "fortnight","$UNIT,14*24*60",
  886. X        "week",        "$UNIT,7*24*60",
  887. X        "day",        "$UNIT,1*24*60",
  888. X        "hour",        "$UNIT,60",
  889. X        "minute",    "$UNIT,1",
  890. X        "min",        "$UNIT,1",
  891. X        "second",    "$SUNIT,1",
  892. X        "sec",        "$SUNIT,1"
  893. X        );
  894. X
  895. X    %othertab = (
  896. X        "tomorrow",    "$UNIT,1*24*60",
  897. X        "yesterday","$UNIT,-1*24*60",
  898. X        "today",    "$UNIT,0",
  899. X        "now",        "$UNIT,0",
  900. X        "last",        "$NUMBER,-1",
  901. X        "this",        "$UNIT,0",
  902. X        "next",        "$NUMBER,2",
  903. X        "first",    "$NUMBER,1",
  904. X        # "second",    "$NUMBER,2",
  905. X        "third",    "$NUMBER,3",
  906. X        "fourth",    "$NUMBER,4",
  907. X        "fifth",    "$NUMBER,5",
  908. X        "sixth",    "$NUMBER,6",
  909. X        "seventh",    "$NUMBER,7",
  910. X        "eigth",    "$NUMBER,8",
  911. X        "ninth",    "$NUMBER,9",
  912. X        "tenth",    "$NUMBER,10",
  913. X        "eleventh",    "$NUMBER,11",
  914. X        "twelfth",    "$NUMBER,12",
  915. X        "ago",        "$AGO,1"
  916. X    );
  917. X
  918. X    %milzone = (
  919. X        "a",        "$ZONE,1 $HRS",
  920. X        "b",        "$ZONE,2 $HRS",
  921. X        "c",        "$ZONE,3 $HRS",
  922. X        "d",        "$ZONE,4 $HRS",
  923. X        "e",        "$ZONE,5 $HRS",
  924. X        "f",        "$ZONE,6 $HRS",
  925. X        "g",        "$ZONE,7 $HRS",
  926. X        "h",        "$ZONE,8 $HRS",
  927. X        "i",        "$ZONE,9 $HRS",
  928. X        "k",        "$ZONE,10 $HRS",
  929. X        "l",        "$ZONE,11 $HRS",
  930. X        "m",        "$ZONE,12 $HRS",
  931. X        "n",        "$ZONE,-1 $HRS",
  932. X        "o",        "$ZONE,-2 $HRS",
  933. X        "p",        "$ZONE,-3 $HRS",
  934. X        "q",        "$ZONE,-4 $HRS",
  935. X        "r",        "$ZONE,-5 $HRS",
  936. X        "s",        "$ZONE,-6 $HRS",
  937. X        "t",        "$ZONE,-7 $HRS",
  938. X        "u",        "$ZONE,-8 $HRS",
  939. X        "v",        "$ZONE,-9 $HRS",
  940. X        "w",        "$ZONE,-10 $HRS",
  941. X        "x",        "$ZONE,-11 $HRS",
  942. X        "y",        "$ZONE,-12 $HRS",
  943. X        "z",        "$ZONE,0 $HRS"
  944. X    );
  945. X
  946. X    @mdays = (31, 0, 31,  30, 31, 30,  31, 31, 30,  31, 30, 31);
  947. X    $epoch = 1970;
  948. X}
  949. X
  950. Xsub lookup {
  951. X    local($id) = @_;
  952. X    local($abbrev, $idvar, $key, $token);
  953. X
  954. X    $idvar = $id;
  955. X    if (length($idvar) == 3) {
  956. X        $abbrev = 1;
  957. X    }
  958. X    elsif (length($idvar) == 4 && substr($idvar, 3, 1) eq '.') {
  959. X        $abbrev = 1;
  960. X        $idvar = substr($idvar, 0, 3);
  961. X    }
  962. X    else {
  963. X        $abbrev = 0;
  964. X    }
  965. X
  966. X    substr($idvar, 0, 1) =~ tr/a-z/A-Z/;
  967. X    if (defined($mdtab{$idvar})) {
  968. X        ($token, $yylval) = split(/,/,$mdtab{$idvar});
  969. X        $yylval = eval "$yylval";
  970. X        return $token;
  971. X    }
  972. X    foreach $key (keys %mdtab) {
  973. X        if ($idvar eq substr($key, 0, 3)) {
  974. X            ($token, $yylval) = split(/,/,$mdtab{$key});
  975. X            $yylval = eval "$yylval";
  976. X            return $token;
  977. X        }
  978. X    }
  979. X    
  980. X    $idvar = $id;
  981. X    if (defined($mztab{$idvar})) {
  982. X        ($token, $yylval) = split(/,/,$mztab{$idvar});
  983. X        $yylval = eval "$yylval";
  984. X        return $token;
  985. X    }
  986. X    
  987. X    $idvar =~ tr/A-Z/a-z/;
  988. X    if (defined($mztab{$idvar})) {
  989. X        ($token, $yylval) = split(/,/,$mztab{$idvar});
  990. X        $yylval = eval "$yylval";
  991. X        return $token;
  992. X    }
  993. X    
  994. X    $idvar = $id;
  995. X    if (defined($unittab{$idvar})) {
  996. X        ($token, $yylval) = split(/,/,$unittab{$idvar});
  997. X        $yylval = eval "$yylval";
  998. X        return $token;
  999. X    }
  1000. X    
  1001. X    if ($idvar =~ /s$/) {
  1002. X        $idvar =~ s/s$//;
  1003. X    }
  1004. X    if (defined($unittab{$idvar})) {
  1005. X        ($token, $yylval) = split(/,/,$unittab{$idvar});
  1006. X        $yylval = eval "$yylval";
  1007. X        return $token;
  1008. X    }
  1009. X    
  1010. X    $idvar = $id;
  1011. X    if (defined($othertab{$idvar})) {
  1012. X        ($token, $yylval) = split(/,/,$othertab{$idvar});
  1013. X        $yylval = eval "$yylval";
  1014. X        return $token;
  1015. X    }
  1016. X    
  1017. X    if (length($idvar) == 1 && $idvar =~ /a-zA-Z/) {
  1018. X        $idvar =~ tr/A-Z/a-z/;
  1019. X        if (defined($milzone{$idvar})) {
  1020. X            ($token, $yylval) = split(/,/,$milzone{$idvar});
  1021. X            $yylval = eval "$yylval";
  1022. X            return $token;
  1023. X        }
  1024. X    }
  1025. X    
  1026. X    return $ID;
  1027. X}
  1028. X
  1029. Xsub main'getdate {
  1030. X    ($dtstr, $now, $timezone) = @_;
  1031. X    local($now, $timezone);
  1032. X    local(@lt);
  1033. X    local($sdate);
  1034. X    local($TZ);
  1035. X
  1036. X    &yyinit;
  1037. X    &lookup_init;
  1038. X    $odtstr = $dtstr;        # Save it for error report--RAM
  1039. X
  1040. X    if (!$now) {
  1041. X        $now = time;
  1042. X    }
  1043. X
  1044. X    if (!$timezone) {
  1045. X        $TZ = defined($ENV{'TZ'}) ? ($ENV{'TZ'} ? $ENV{'TZ'} : '') : '';
  1046. X        if( $TZ =~
  1047. X           /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/) {
  1048. X            $timezone = $2 * 60;
  1049. X        }
  1050. X        else {
  1051. X            $timezone = 0;
  1052. X        }
  1053. X    }
  1054. X
  1055. X    @lt = localtime($now);
  1056. X    $year = 0;
  1057. X    $month = $lt[4] + 1;
  1058. X    $day = $lt[3];
  1059. X    $relsec = $relmonth = 0;
  1060. X    $timeflag = $zoneflag = $dateflag = $dayflag = $relflag = 0;
  1061. X    $daylight = $MAYBE;
  1062. X    $hh = $mm = $ss = 0;
  1063. X    $merid = 24;
  1064. X    
  1065. X    $dtstr =~ tr/A-Z/a-z/;
  1066. X    return -1 if &yyparse;
  1067. X    return -1 if $timeflag > 1 || $zoneflag > 1 || $dateflag > 1 || $dayflag > 1;
  1068. X
  1069. X    if (!$year) {
  1070. X        $year = ($month > ($lt[4] + 1)) ? ($lt[5] - 1) : $lt[5];
  1071. X    }
  1072. X
  1073. X    if ($dateflag || $timeflag || $dayflag) {
  1074. X        $sdate = &dateconv($month, $day, $year, $hh, $mm, $ss,
  1075. X                           $merid, $timezone, $daylight);
  1076. X        if ($sdate < 0) {
  1077. X            return -1;
  1078. X        }
  1079. X    }
  1080. X    else {
  1081. X        $sdate = $now;
  1082. X        if ($relflag == 0) {
  1083. X            $sdate -= ($lt[0] + $lt[1] * 60 + $lt[2] * (60 * 60));
  1084. X        }
  1085. X    }
  1086. X    
  1087. X    $sdate += $relsec + &monthadd($sdate, $relmonth);
  1088. X    $sdate += &dayconv($dayord, $dayreq, $sdate) if ($dayflag && !$dateflag);
  1089. X    
  1090. X    return $sdate;
  1091. X}
  1092. X
  1093. X# Mark error within date string with a '^' cursor--RAM
  1094. Xsub yyerror {
  1095. X    local($parsed) = length($odstr) - length($dtstr);
  1096. X    substr($odtstr, $parsed) = '^' .  substr($odtstr, $parsed + 1);
  1097. X    &'add_log("syntax error in date: $odtstr") if $'loglvl > 5;
  1098. X}
  1099. X
  1100. Xpackage main;
  1101. X
  1102. END_OF_FILE
  1103.   if test 26463 -ne `wc -c <'agent/pl/getdate.pl'`; then
  1104.     echo shar: \"'agent/pl/getdate.pl'\" unpacked with wrong size!
  1105.   fi
  1106.   # end of 'agent/pl/getdate.pl'
  1107. fi
  1108. if test -f 'agent/pl/stats.pl' -a "${1}" != "-c" ; then 
  1109.   echo shar: Will not clobber existing file \"'agent/pl/stats.pl'\"
  1110. else
  1111.   echo shar: Extracting \"'agent/pl/stats.pl'\" \(23184 characters\)
  1112.   sed "s/^X//" >'agent/pl/stats.pl' <<'END_OF_FILE'
  1113. X;# $Id: stats.pl,v 2.9.1.1 92/08/26 13:18:36 ram Exp $
  1114. X;#
  1115. X;#  Copyright (c) 1992, Raphael Manfredi
  1116. X;#
  1117. X;#  You may redistribute only under the terms of the GNU General Public
  1118. X;#  Licence as specified in the README file that comes with dist.
  1119. X;#
  1120. X;# $Log:    stats.pl,v $
  1121. X;# Revision 2.9.1.1  92/08/26  13:18:36  ram
  1122. X;# patch8: added statistics suppression code
  1123. X;# 
  1124. X;# Revision 2.9  92/07/14  16:50:52  ram
  1125. X;# 3.0 beta baseline.
  1126. X;# 
  1127. X;# 
  1128. X;# Handle the mailagent statistics file. This file is known as the statfile
  1129. X;# in the configuration file (typically mailagent.st in the spool directory).
  1130. X;# This file contains a summary of the action taken by the mailagent. The very
  1131. X;# first line contains: mailstat: <timestamp> which is the date the statistics
  1132. X;# started.
  1133. X;#
  1134. X;# The following format is used for each records:
  1135. X;#
  1136. X;#    <timestamp> 0 0
  1137. X;#    <# of mails processed> <# commands run> <# of failures> <# of bytes>
  1138. X;#    <rule number> <mode> <number of matches>
  1139. X;#    "default" <number of matches>
  1140. X;#    "vacation" <number of vaction messages sent>
  1141. X;#    "seen" <number of messages already seen>
  1142. X;#    "saved" <number of messages saved by default>
  1143. X;#    <command name> <mode> <number of execution>
  1144. X;#    !<command name> <mode> <number of failures>
  1145. X;#    @<command name> <mode> <tag> <number of execution>
  1146. X;#    %@<command name> <mode> <tag> <number of non-executed commands>
  1147. X;#    --------
  1148. X;#    <output of rule dumping>
  1149. X;#    ++++++++
  1150. X;#
  1151. X;# The leading timestamp records the stamp on the rule file, followed by two
  1152. X;# zeros (currently unused locations, reserved for future use, as they say).
  1153. X;#
  1154. X;# The number of mails processed is only stored to check the consistency of the
  1155. X;# statistics file. Likewise, the number of commands run and the number of
  1156. X;# failed commands are used to check the logging accuracy.
  1157. X;#
  1158. X;# Lines starting with a number indicate a match for a particular rule, in
  1159. X;# a given mode. The "default", "vacation" and "seen" lines record the activity
  1160. X;# of the default action, the vacation mode or the messages already processed
  1161. X;# which come back.
  1162. X;#
  1163. X;# Commands are also logged. They are always spelled upper-cased. If the line
  1164. X;# starts with a '!', it indicates a failure. If the character '@' is found
  1165. X;# before the command name, it indicates a ONCE command. The tag part of the
  1166. X;# identification is logged, but not the name (which is likely to be an e-mail
  1167. X;# address anyway, whereas the tag identifies the command itself). The lines
  1168. X;# starting with '%' also give the number of ONCE commands which were not
  1169. X;# executed because the retry time was not reached.
  1170. X;#
  1171. X;# Below the dashed line, all the rules are dumped in order, and are separated
  1172. X;# by a blank line. These are the rules listed in the rule file and they are
  1173. X;# given for information purposes only, when reporting statistics. It ends with
  1174. X;# a plus line.
  1175. X;#
  1176. X;# Whenever the rule file is updated, another record is started after having
  1177. X;# been diffing the rules we have parsed with the rules dumped in the statistics
  1178. X;# file.
  1179. X;#
  1180. X;# In order to improve performances, the statistics file is cached in memory.
  1181. X;# Only the last record is read, up to the dashed-line. The data structures
  1182. X;# used are:
  1183. X;#
  1184. X;#     @stats'Top: the top seven fields of the record:
  1185. X;#         (time, 0, 0, processed, run, failed, bytes)
  1186. X;#     %stats'Rule: indexed by <N>+mode, the number of matches
  1187. X;#     %stats'Special: indexed by "default", "vacation", "saved" or "seen"
  1188. X;#     %stats'Command: indexed by name+mode, the total number of runs
  1189. X;#         this accounts for ONCE commands as well.
  1190. X;#     %stats'FCommand: indexed by name+mode, the number of failures
  1191. X;#         this accounts for ONCE commands as well.
  1192. X;#     %stats'Once: indexed by name+mode+tag, the number of succesful runs
  1193. X;#     %stats'ROnce: indexed by name+mode+tag, number of non-executed comands
  1194. X;#
  1195. Xpackage stats;
  1196. X
  1197. X$stats_wanted = 0;                # No statistics wanted by default
  1198. X$new_record = 0;                # True when a new record is to be started
  1199. X$start_date = 0;                # When statistics started
  1200. X$suppressed = 0;                # Statistics suppressed by higher authority
  1201. X
  1202. X# Suppress statistics. This function is called when options like -r or -e are
  1203. X# used. Those usually specify one time rules and thus are not entitled to be
  1204. X# recorded into the statistics.
  1205. Xsub main'no_stats { $suppressed = 1; }
  1206. X
  1207. X# Read the statistics file and fill in the hash tables
  1208. Xsub main'read_stats {
  1209. X    local($statfile) = $cf'statfile;    # Extract value from config package
  1210. X    local($loglvl) = $main'loglvl;
  1211. X    local($_, $.);
  1212. X    $stats_wanted = 1 if ($statfile ne '' && -f $statfile);
  1213. X    $stats_wanted = 0 if $suppressed;
  1214. X    return unless $stats_wanted;
  1215. X    # Do not come here unless statistics are really wanted
  1216. X    unless (open(STATS, "$statfile")) {
  1217. X        &'add_log("ERROR could not open statistics file $statfile: $!")
  1218. X            if $loglvl > 0;
  1219. X        $stats_wanted = 0;        # Cannot keep track of statistics
  1220. X        return;
  1221. X    }
  1222. X    local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime,
  1223. X        $ctime,$blksize,$blocks) = stat($cf'rules);
  1224. X    # A null size means we have to start over again
  1225. X    unless (-s $statfile) {
  1226. X        &'add_log("starting new statistics") if $loglvl > 6;
  1227. X        $start_date = time;
  1228. X        close STATS;
  1229. X        @Top = ($mtime, 0, 0, 0, 0, 0, 0);
  1230. X        return;
  1231. X    }
  1232. X    $_ = <STATS>;
  1233. X    unless (/^mailstat: (\d+)/) {
  1234. X        &'add_log("ERROR corrupted statistics file $statfile") if $loglvl > 0;
  1235. X        close STATS;
  1236. X        $stats_wanted = 0;
  1237. X        return;
  1238. X    } else {
  1239. X        $start_date = $1;
  1240. X    }
  1241. X    # The first record is always the active one. Check the timestamp. If the
  1242. X    # rule file has changed, check the sums.
  1243. X    $_ = <STATS>;
  1244. X    local($timestamp, $unused_1, $unused_2) = split(' ', $_);
  1245. X    if ($main'edited_rules || $mtime > $timestamp) {    # File was modified?
  1246. X        # Reset timestamp for next time if rule come from a file.
  1247. X        $timestamp = $mtime;
  1248. X        $timestamp = 0 if $main'edited_rules;
  1249. X        &'add_log("rule file may have changed") if $loglvl > 18;
  1250. X        $new_record = &diff_rules($statfile);        # Run the full diff then
  1251. X        if ($new_record) {
  1252. X            &'add_log("rule file has changed") if $loglvl > 6;
  1253. X            @Top = ($mtime, 0, 0, 0, 0, 0, 0);
  1254. X            close STATS;
  1255. X            $start_date = time;
  1256. X            return;
  1257. X        }
  1258. X        &'add_log("rule file has not changed") if $loglvl > 6;
  1259. X    }
  1260. X    # Read second line and build the @Top array
  1261. X    $_ = <STATS>;
  1262. X    local($processed, $run, $failed, $bytes) = split(' ', $_);
  1263. X    @Top =
  1264. X        ($timestamp, $unused_1, $unused_2, $processed, $run, $failed, $bytes);
  1265. X    local($valid) = 0;            # Set to true when a valid record was found
  1266. X    &fill_stats;                # Fill in data structures
  1267. X    close STATS;
  1268. X    &'add_log('statistics initialized and loaded') if $loglvl > 18;
  1269. X}
  1270. X
  1271. X# Write the statistics file
  1272. Xsub main'write_stats {
  1273. X    local($statfile) = $cf'statfile;    # Extract value from config package
  1274. X    local($loglvl) = $main'loglvl;
  1275. X    return unless $stats_wanted;
  1276. X    local($oldstat) = -f $statfile;
  1277. X    if ($oldstat) {
  1278. X        unlink("$statfile.b") if -f "$statfile.b";
  1279. X        unless (rename($statfile, "$statfile.b")) {
  1280. X            &'add_log("ERROR cannot rename $statfile as $statfile.b: $!")
  1281. X                if $loglvl;
  1282. X            return;
  1283. X        }
  1284. X    }
  1285. X    unless (open(STATS, ">$statfile")) {
  1286. X        &'add_log("ERROR cannot create $statfile: $!") if $loglvl;
  1287. X        return;
  1288. X    }
  1289. X    # If a new record is to be created, do it at the top of the file, then
  1290. X    # append the old statistics file at the end of it. Otherwise, the first
  1291. X    # record of the old statistics file is removed and the remaining is
  1292. X    # appended.
  1293. X    print STATS "mailstat: $start_date\n";        # Magic line
  1294. X    print STATS join(' ', @Top[0..2]), "\n";
  1295. X    print STATS join(' ', @Top[3..$#Top]), "\n";
  1296. X    &print_array(*Rule, "");            # Print rule matches statistics
  1297. X    &print_array(*Special, "");            # Print special stats
  1298. X    &print_array(*Command, "");            # Print actions executions
  1299. X    &print_array(*FCommand, "!");        # Print failed actions
  1300. X    &print_array(*Once, "@");            # Print once commands done
  1301. X    &print_array(*ROncem, "%@");        # Print once commands not retried
  1302. X    print STATS "------\n";
  1303. X    &dump_internal_rules(STATS);
  1304. X    print STATS "++++++\n";
  1305. X    # If there was no previous statistics file, it's done!
  1306. X    unless ($oldstat) {
  1307. X        close STATS;
  1308. X        return;
  1309. X    }
  1310. X    unless (open(OLD, "$statfile.b")) {
  1311. X        &'add_log("ERROR cannot open old statistics file") if $loglvl;
  1312. X        close STATS;
  1313. X        return;
  1314. X    }
  1315. X    # If no new record was created, we have to skip the first record of the old
  1316. X    # statistics file before appending.
  1317. X    unless ($new_record) {
  1318. X        while (<OLD>) {
  1319. X            last if /^\+\+\+\+\+\+/;
  1320. X        }
  1321. X    }
  1322. X    # It's fine to only check the return status of print right now. If there is
  1323. X    # not enough space on the device, we won't be able to append the whole
  1324. X    # backup file, but then we have to discard previously saved statistics
  1325. X    # anyway...
  1326. X    local($status) = print STATS <OLD>;
  1327. X    close OLD;
  1328. X    close STATS;
  1329. X    if ($status) {                        # Print ran ok
  1330. X        unlink("$statfile.b");
  1331. X    } else {                            # Print failed
  1332. X        &'add_log("ERROR could not update statistics: $!") if $loglvl;
  1333. X        unless (rename("$statfile.b", $statfile)) {
  1334. X            &'add_log("ERROR could not restore old statistics file: $!")
  1335. X                if $loglvl;
  1336. X        }
  1337. X    }
  1338. X}
  1339. X
  1340. X# Print the hash table array in STATS file
  1341. Xsub print_array {
  1342. X    local(*name, $leader) = @_;
  1343. X    local(@keys);
  1344. X    foreach (sort keys %name) {
  1345. X        @keys = split(/:/);
  1346. X        print STATS $leader . join(' ', @keys) . ' ' . $name{$_}, "\n";
  1347. X    }
  1348. X}
  1349. X
  1350. X#
  1351. X# Accounting routines
  1352. X#
  1353. X
  1354. X# Record a mail processing
  1355. Xsub main's_filtered {
  1356. X    return unless $stats_wanted;
  1357. X    local($length) = @_;
  1358. X    $Top[3]++;
  1359. X    $Top[6] += $length;
  1360. X}
  1361. X
  1362. X# Record a rule match
  1363. Xsub main's_match {
  1364. X    return unless $stats_wanted;
  1365. X    local($number, $mode) = @_;
  1366. X    $Rule{"$number:$mode"}++;
  1367. X}
  1368. X
  1369. X# Record a default rule
  1370. Xsub main's_default {
  1371. X    return unless $stats_wanted;
  1372. X    $Special{'default'}++;
  1373. X}
  1374. X
  1375. X# Record a vacation message sent in vacation mode
  1376. Xsub main's_vacation {
  1377. X    return unless $stats_wanted;
  1378. X    $Special{'vacation'}++;
  1379. X}
  1380. X
  1381. X# Record a message saved by the default action
  1382. Xsub main's_saved {
  1383. X    return unless $stats_wanted;
  1384. X    $Special{'saved'}++;
  1385. X}
  1386. X
  1387. X# Record an already processed message
  1388. Xsub main's_seen {
  1389. X    return unless $stats_wanted;
  1390. X    $Special{'seen'}++;
  1391. X}
  1392. X
  1393. X# Record a successful execution
  1394. Xsub main's_action {
  1395. X    return unless $stats_wanted;
  1396. X    local($name, $mode) = @_;
  1397. X    $Command{"$name:$mode"}++;
  1398. X    $Top[4]++;
  1399. X}
  1400. X
  1401. X# Record a failed execution
  1402. Xsub main's_failed {
  1403. X    return unless $stats_wanted;
  1404. X    local($name, $mode) = @_;
  1405. X    $Command{"$name:$mode"}++;
  1406. X    $FCommand{"$name:$mode"}++;
  1407. X    $Top[4]++;
  1408. X    $Top[5]++;
  1409. X}
  1410. X
  1411. X# Record a successful once
  1412. Xsub main's_once {
  1413. X    return unless $stats_wanted;
  1414. X    local($name, $mode, $tag) = @_;
  1415. X    $Once{"$name:$mode:$tag"}++;
  1416. X}
  1417. X
  1418. X# Record a non-retried once
  1419. Xsub main's_noretry {
  1420. X    return unless $stats_wanted;
  1421. X    local($name, $mode, $tag) = @_;
  1422. X    $ROnce{"$name:$mode:$tag"}++;
  1423. X}
  1424. X
  1425. X#
  1426. X# Low-level routines
  1427. X#
  1428. X
  1429. X# Establish a difference between the rules we have in memory and the rules
  1430. X# that has been dumped at the end of the active record. Return the difference
  1431. X# status, true or false.
  1432. Xsub diff_rules {
  1433. X    local($file) = @_;                    # Statistics file where dump is stored
  1434. X    local(*loglvl) = *main'loglvl;
  1435. X    local($_, $.);
  1436. X    open(FILE, "$file") || return 1;    # Changed if we cannot re-open file
  1437. X    # Go past the first dashed line, where the dumped rules begin
  1438. X    while (<FILE>) {
  1439. X        last if /^------/;
  1440. X    }
  1441. X    # The difference is done on the internal representation of the rules,
  1442. X    # which gives us a uniform and easy way to make sure the rules did not
  1443. X    # change.
  1444. X    local(*Rules) = *main'Rules;        # The @Rules array
  1445. X    local($i) = 0;                        # Index in the rules
  1446. X    while (<FILE>) {
  1447. X        last if /^\+\+\+\+\+\+/;        # End of dumped rules
  1448. X        last if $i > $#Rules;
  1449. X        chop;
  1450. X        last unless $_ eq $Rules[$i];    # Compare rule with internal form
  1451. X        $i++;                            # Index in the @Rules array
  1452. X    }
  1453. X    if ($i <= $#Rules) {                # If one rule did not match
  1454. X        close FILE;
  1455. X        ++$i;
  1456. X        &'add_log("rule $i did not match") if $loglvl > 11;
  1457. X        return 1;                        # Rule file has changed
  1458. X    }
  1459. X    # Now check the hash table entries
  1460. X    local(*Rule) = *main'Rule;            # The %Rule array
  1461. X    local(@keys) =
  1462. X        sort hashkey keys(%Rule);        # Sorted keys H0, H1, etc...
  1463. X    $i = 0;                                # Reset index
  1464. X    while (<FILE>) {                    # Swallow blank line
  1465. X        last if /^\+\+\+\+\+\+/;        # End of dumped rules
  1466. X        last if $i > $#keys;
  1467. X        chop;
  1468. X        last unless $_ eq $Rule{$keys[$i]};
  1469. X        $i++;                            # Index in @keys
  1470. X    }
  1471. X    if ($i <= $#keys) {                    # Changed if one rule did not match
  1472. X        close FILE;
  1473. X        ++$i;
  1474. X        &'add_log("hrule $i did not match") if $loglvl > 11;
  1475. X        return 1;                        # Rule file has changed
  1476. X    }
  1477. X    close FILE;
  1478. X    return 1 unless /^\+\+\+\+\+\+/;    # More rules to come
  1479. X    0;                                    # Rule file did not change
  1480. X}
  1481. X
  1482. X# Sorting for hash keys used by %Rule
  1483. Xsub hashkey {
  1484. X    local($c) = $a =~ /^H(\d+)/;
  1485. X    local($d) = $b =~ /^H(\d+)/;
  1486. X    $c <=> $d;
  1487. X}
  1488. X
  1489. X# Dump the internal form of the rules
  1490. Xsub dump_internal_rules {
  1491. X    local($file) = @_;                # Filehandle in which rules are to be dumped
  1492. X    local(*Rules) = *main'Rules;    # The main rule array
  1493. X    local(*Rule) = *main'Rule;        # The hash table for patterns and selectors
  1494. X    print $file join("\n", @Rules), "\n";
  1495. X    print $file "\n";                # A blank line separates tables
  1496. X    foreach (sort hashkey keys %Rule) {
  1497. X        print $file $Rule{$_}, "\n";
  1498. X    }
  1499. X}
  1500. X
  1501. X# Read pre-opened STATS file descriptor and fill in the statistics arrays
  1502. Xsub fill_stats {
  1503. X    while (<STATS>) {
  1504. X        last if /^------/;        # Reached end of statistics
  1505. X        if (/^(\d+)\s+(\w+)\s+(\d+)/) {                # <rule> <mode> <# match>
  1506. X            $Rule{"$1:$2"} = int($3);
  1507. X        } elsif (/^([a-z]+)\s+(\d+)/) {                # <special> <# match>
  1508. X            $Special{$1} = $2;                        # first token is the key
  1509. X        } elsif (/^([A-Z]+)\s+(\w+)\s+(\d+)/) {        # <cmd> <mode> <# succes>
  1510. X            $Command{"$1:$2"} = int($3);
  1511. X        } elsif (/^!([A-Z]+)\s+(\w+)\s+(\d+)/) {    # <cmd> <mode> <# fail>
  1512. X            $FCommand{"$1:$2"} = int($3);
  1513. X        } elsif (/^@([A-Z]+)\s+(\w+)\s+(\S+)\s+(\d+)/) {    # Once run
  1514. X            $Once{"$1:$2:$3"} = int($4);
  1515. X        } elsif (/^%@([A-Z]+)\s+(\w+)\s+(\S+)\s+(\d+)/) {    # Once not retried
  1516. X            $ROnce{"$1:$2:$3"} = int($4);
  1517. X        } else {
  1518. X            &'add_log("ERROR corrupted line $. in statistics file") if $loglvl;
  1519. X        }
  1520. X    }
  1521. X}
  1522. X
  1523. X#
  1524. X# Reporting statistics
  1525. X#
  1526. X
  1527. X# Dump the statistics on the standard output.
  1528. X# Here are the possible options:
  1529. X#   u: print only used rules
  1530. X#   m: merge all the statistics at the end
  1531. X#   a: all mode reported
  1532. X#   r: rule-based statistics, on a per-state basis
  1533. X#   y: USELESS if -m, but kept for nice mnemonic
  1534. Xsub main'report_stats {
  1535. X    require 'ctime.pl';
  1536. X    local($option) = @_;                # Options from command line
  1537. X    local($opt_u) = $option =~ /u/;        # Only used rules
  1538. X    local($opt_m) = $option =~ /m/;        # Merge all statistics at the end
  1539. X    local($opt_a) = $option =~ /a/;        # Print mode-related statistics
  1540. X    local($opt_r) = $option =~ /r/;        # Print rule-based statistics
  1541. X    local($opt_y) = $option =~ /y/;        # Yield rule-based summary
  1542. X    local($statfile) = $cf'statfile;
  1543. X    local(*loglvl) = *main'loglvl;
  1544. X    local($_, $.);
  1545. X    select(STDOUT);
  1546. X    unless ($statfile ne '' && -f "$statfile") {
  1547. X        print "No statistics available.\n";
  1548. X        return;
  1549. X    }
  1550. X    unless (open(STATS, "$statfile")) {
  1551. X        print "Can't open $statfile: $!\n";
  1552. X        return;
  1553. X    }
  1554. X    unless (-s $statfile) {
  1555. X        print "Statistics file is empty.\n";
  1556. X        close STATS;
  1557. X        return;
  1558. X    }
  1559. X    local($lasttime) = time;    # End of last dumped period
  1560. X    local($start) = $lasttime;    # Save current time
  1561. X    local($amount);                # Number of mails processed
  1562. X    local($bytes);                # Bytes processed
  1563. X    local($actions);            # Number of actions
  1564. X    local($failures);            # Failures reported
  1565. X    local(%Cmds);                # Execution / action
  1566. X    local(%FCmds);                # Failures / action
  1567. X    local(%Spec);                # Summary of special actions
  1568. X    local(%Mrule);                # For merged rules statistics
  1569. X    local($in_summary);            # True when in summary
  1570. X    1 while &print_stats;        # Print statistics for each record
  1571. X    close STATS;
  1572. X    if ($opt_m) {
  1573. X        $in_summary = 1;                # Signal in summary part
  1574. X        $Top[3] = $amount;                # Number of mails processed
  1575. X        $Top[4] = $actions;                # Number of mails processed
  1576. X        $Top[5] = $failures;            # Failures reported
  1577. X        $Top[6] = $bytes;                # Bytes processed
  1578. X        $current_time = $lasttime;
  1579. X        $lasttime = $start;
  1580. X        local(*Special) = *Spec;        # Alias %Spec into %Special
  1581. X        &print_general("Summary");
  1582. X        local(*Command) = *Cmds;        # Alias %Cmds into %Command
  1583. X        local(*FCommand) = *FCmds;        # Alias %FCmds into %FCommand
  1584. X        &print_commands;                # Commands summary
  1585. X        &print_rules_summary;            # Print rules summary
  1586. X    }
  1587. X}
  1588. X
  1589. X# Print statistics for one record. This subroutine exectues in the context
  1590. X# built by report_stats. I heavily used dynamic scope hereafter to avoid code
  1591. X# duplication.
  1592. Xsub print_stats {
  1593. X    return 0 if eof(STATS);
  1594. X    $_ = <STATS>;
  1595. X    unless (/^mailstat: (\d+)/) {
  1596. X        print "Statistics file is corrupted, line $.\n";
  1597. X        return 0;
  1598. X    }
  1599. X    local($current_time) = $1;
  1600. X    # Build a valid context for data structures fill-in
  1601. X    local(@Top, %Rule, %Special, %Command, %FCommand, %Once, %ROnce);
  1602. X    # The two first line are the @Top array
  1603. X    $_ = <STATS>;
  1604. X    $_ .= <STATS>;
  1605. X    chop;
  1606. X    @Top = split(/\s+/);
  1607. X    &fill_stats;                        # Fill in local data structures
  1608. X    &print_summary;                        # Print local summary
  1609. X    # Now build a valid context for rule dumping
  1610. X    local(@main'Rules, %main'Rule);
  1611. X    local($i) = 0;                        # Force numeric context
  1612. X    local($hash);                        # True when entering %Rule section
  1613. X    while (<STATS>) {
  1614. X        last if /^\+\+\+\+\+\+/;
  1615. X        chop;
  1616. X        if (/^$/) {
  1617. X            $hash = 1;                    # Separator between @Rules and %Rule
  1618. X            next;
  1619. X        }
  1620. X        unless ($hash) {
  1621. X            push(@main'Rules, $_);
  1622. X        } else {
  1623. X            $main'Rule{"H$i"} = $_;
  1624. X            $i++;
  1625. X        }
  1626. X    }
  1627. X    &main'dump_rules(*print_header, *rule_stats);
  1628. X    print '=' x 79, "\n";
  1629. X    $lasttime = $current_time;
  1630. X}
  1631. X
  1632. X# Print a summary from a given record
  1633. Xsub print_summary {
  1634. X    &print_general("Statistics");
  1635. X    &print_commands;                        # Commands summary
  1636. X    $amount += $Top[3];                        # Number of mails processed
  1637. X    $bytes += $Top[6];                        # Bytes processed
  1638. X    $actions += $Top[4];                    # Actions exectuted
  1639. X    $failures += $Top[5];                    # Failures reported
  1640. X    foreach (keys %Special) {                # Special statistics
  1641. X        $Spec{$_} += $Special{$_};
  1642. X    }
  1643. X    foreach (keys %Command) {                # Commands ececuted
  1644. X        $Cmds{$_} += $Command{$_};
  1645. X    }
  1646. X    foreach (keys %FCommand) {                # Failed commands
  1647. X        $FCmds{$_} += $FCommand{$_};
  1648. X    }
  1649. X}
  1650. X
  1651. X# Print general informations, as found in @Top.
  1652. Xsub print_general {
  1653. X    local($what) = @_;
  1654. X    local($last) = &'ctime($lasttime);
  1655. X    local($now) = &'ctime($current_time);
  1656. X    local($n, $s);
  1657. X    chop $now;
  1658. X    chop $last;
  1659. X    # Header of statistics
  1660. X    print "$what from $now to $last:\n";
  1661. X    print '~' x 79, "\n";
  1662. X    print "Processed $Top[3] mail";
  1663. X    print "s" unless $Top[3] == 1;
  1664. X    print " for a total of $Top[6] bytes";
  1665. X    $n = $Special{'seen'};
  1666. X    $s = $n == 1 ? '' : 's';
  1667. X    print " ($n mail$s already seen)" if $n;
  1668. X    print ".\n";
  1669. X    print "Executed $Top[4] action";
  1670. X    print "s" unless $Top[4] == 1;
  1671. X    local($failed) = $Top[5];
  1672. X    unless ($failed) {
  1673. X        print " with no failure.\n";
  1674. X    } else {
  1675. X        print ", $failed of which failed.\n";
  1676. X    }
  1677. X    $n = $Special{'default'};
  1678. X    $s = $n == 1 ? '' : 's';
  1679. X    print "The default rule was applied $n time$s";
  1680. X    $n = $Special{'saved'};
  1681. X    $s = $n == 1 ? '' : 's';
  1682. X    local($was) = $n == 1 ? 'was' : 'were';
  1683. X    print " and $n message$s $was implicitely saved" if $n;
  1684. X    print ".\n";
  1685. X    $n = $Special{'vacation'};
  1686. X    $s = $n == 1 ? '' : 's';
  1687. X    print "Received $n message$s in vacation mode with no rule match.\n" if $n;
  1688. X}
  1689. X
  1690. X# Print the commands executed, as found in %Command and @Top.
  1691. Xsub print_commands {
  1692. X    print '~' x 79, "\n";
  1693. X    local($cmd, $mode);
  1694. X    local(%states, %fstates);
  1695. X    local(%cmds, %fcmds);
  1696. X    local(@kstates, @fkstates);
  1697. X    local($n, $s);
  1698. X    foreach (keys %Command) {
  1699. X        ($cmd, $mode) = /^(\w+):(\w+)/;
  1700. X        $n = $Command{$_};
  1701. X        $cmds{$cmd} += $n;
  1702. X        $states{"$cmd:$mode"} += $n;
  1703. X    }
  1704. X    foreach (keys %FCommand) {
  1705. X        ($cmd, $mode) = /^(\w+):(\w+)/;
  1706. X        $n = $FCommand{$_};
  1707. X        $fcmds{$cmd} += $n;
  1708. X        $fstates{"$cmd:$mode"} += $n;
  1709. X    }
  1710. X    local($total) = $Top[4];
  1711. X    local($percentage);
  1712. X    local($cmd_total);
  1713. X    foreach $key (sort keys %cmds) {
  1714. X        @kstates = sort grep(/^$key:/, keys %states);
  1715. X        $cmd_total = $n = $cmds{$key};
  1716. X        $s = $n == 1 ? '' : 's';
  1717. X        $percentage = '0.00';
  1718. X        $percentage = sprintf("%.2f", ($n / $total) * 100) if $total;
  1719. X        print "$key run $n time$s ($percentage %)";
  1720. X        if (@kstates == 1) {
  1721. X            ($mode) = $kstates[0] =~ /^\w+:(\w+)/;
  1722. X            print " in state $mode";
  1723. X        } else {
  1724. X            $n = @kstates;
  1725. X            print " in $n states";
  1726. X        }
  1727. X        if (defined($fcmds{$key}) && ($n = $fcmds{$key})) {
  1728. X            $s = $n == 1 ? '' : 's';
  1729. X            $percentage = sprintf("%.2f", ($n / $cmd_total) * 100);
  1730. X            print " and failed $n time$s ($percentage %)";
  1731. X        }
  1732. X        if (@kstates == 1 || !$opt_a) {
  1733. X            print ".\n";
  1734. X        } else {
  1735. X            print ":\n";
  1736. X            @fkstates = sort grep(/^$key:/, keys %states);
  1737. X            foreach (@kstates) {
  1738. X                ($mode) = /^\w+:(\w+)/;
  1739. X                $n = $states{$_};
  1740. X                $s = $n == 1 ? '' : 's';
  1741. X                $percentage = sprintf("%.2f", ($n / $cmd_total) * 100);
  1742. X                print "    state $mode: $n time$s ($percentage %)";
  1743. X                $n = $fstates{$_};
  1744. X                $s = $n == 1 ? '' : 's';
  1745. X                print ", $n failure$s" if $n;
  1746. X                print ".\n";
  1747. X            }
  1748. X        }
  1749. X    }
  1750. X}
  1751. X
  1752. X# Return a uniform representation of a rule (suitable for usage merging)
  1753. Xsub uniform_rule {
  1754. X    local($rulenum) = @_;
  1755. X    local($text) = $main'Rules[$rulenum - 1];
  1756. X    $text =~ s/^(.*}\s+)//;                    # Get mode and action
  1757. X    local($rule) = $1;
  1758. X    local(@keys) = split(' ', $text);        # H keys for selection / patterns
  1759. X    foreach (@keys) {
  1760. X        $rule .= "\n" . $main'Rule{$_};        # Add selectors and patterns
  1761. X    }
  1762. X    $rule;
  1763. X}
  1764. X
  1765. X# Print a summary of merged rules as found in %Mrule
  1766. Xsub print_rules_summary {
  1767. X    return unless $opt_y;
  1768. X    local(@main'Rules);                # The main rules array
  1769. X    local(%main'Rule);                # The H table for selectors and patterns
  1770. X    local($counter) = 0;            # Counter for H key computation
  1771. X    local($rulenum) = 0;            # Rule number
  1772. X    local(%Rule);                    # The local rule statistics array
  1773. X    local(@components);                # Rule components
  1774. X    local($rule);                    # Constructed rule
  1775. X    foreach (keys %Mrule) {
  1776. X        s/^(\w+)://;                # Get applied state
  1777. X        $state = $1;
  1778. X        @components = split(/\n/);
  1779. X        $rule = shift(@components);
  1780. X        foreach (@components) {
  1781. X            $rule .= " H$counter";
  1782. X            $main'Rule{"H$counter"} = $_;
  1783. X            $counter++;
  1784. X        }
  1785. X        push(@main'Rules, $rule);
  1786. X        $rulenum++;
  1787. X        $Rule{"$rulenum:$state"} += $Mrule{"$state:$_"};
  1788. X    }
  1789. X    &main'dump_rules(*print_header, *rule_stats);
  1790. X}
  1791. X
  1792. X#
  1793. X# Hooks for rule dumping
  1794. X#
  1795. X
  1796. X# Print the rule number and the number of applications
  1797. Xsub print_header {
  1798. X    local($rulenum) = @_;
  1799. X    local($total_matches) = 0;
  1800. X    local(@keys) = grep(/^$rulenum:/, keys %Rule);
  1801. X    local($state);
  1802. X    local($matches);
  1803. X    # Add up the usage of rules, whatever the matching state was
  1804. X    foreach (@keys) {
  1805. X        $matches = $Rule{$_};
  1806. X        $total_matches += $matches;
  1807. X        if ($opt_y && !$in_summary) {
  1808. X            ($state) = /^\d+:(.*)/;
  1809. X            $_ = $state . ":" . &uniform_rule($rulenum);
  1810. X            $Mrule{$_} += $matches;
  1811. X        }
  1812. X    }
  1813. X    return 0 if ($opt_u && $total_matches == 0);
  1814. X    return 0 unless $opt_r;
  1815. X    local($total) = $Top[3];
  1816. X    $total = 1 unless $total;
  1817. X    local($percentage) = sprintf("%.2f", ($total_matches / $total) * 100);
  1818. X    $percentage = '0' if $total_matches == 0;
  1819. X    local($s) = $total_matches == 1 ? '' : 's';
  1820. X    print '-' x 79, "\n";
  1821. X    print "Rule #$rulenum, applied $total_matches time$s ($percentage %).\n";
  1822. X}
  1823. X
  1824. X# Print the rule applications, on a per-state basis
  1825. Xsub rule_stats {
  1826. X    return unless $opt_r;
  1827. X    local($rulenum) = @_;
  1828. X    local($mode) = $main'Rules[$rulenum - 1] =~ /^(.*)\s+{/;
  1829. X    return unless $mode =~ /,/ || $mode eq 'ALL';
  1830. X    local(@keys) = grep(/^$rulenum:/, keys %Rule);
  1831. X    local(%states);
  1832. X    local($s, $total);
  1833. X    foreach (@keys) {
  1834. X        /^\d+:(.+)/;
  1835. X        $states{$1}++;
  1836. X    }
  1837. X    @keys = keys %states;
  1838. X    return unless $opt_a;
  1839. X    if (@keys == 1) {
  1840. X        print "Applied only in state $keys[0].\n";
  1841. X    } else {
  1842. X        foreach (@keys) {
  1843. X            $total = $states{$_};
  1844. X            $s = $total == 1 ? '' : 's';
  1845. X            print "State $_: $total time$s.\n";
  1846. X        }
  1847. X    }
  1848. X}
  1849. X
  1850. Xpackage main;
  1851. X
  1852. END_OF_FILE
  1853.   if test 23184 -ne `wc -c <'agent/pl/stats.pl'`; then
  1854.     echo shar: \"'agent/pl/stats.pl'\" unpacked with wrong size!
  1855.   fi
  1856.   # end of 'agent/pl/stats.pl'
  1857. fi
  1858. echo shar: End of archive 6 \(of 17\).
  1859. cp /dev/null ark6isdone
  1860. MISSING=""
  1861. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 ; do
  1862.     if test ! -f ark${I}isdone ; then
  1863.     MISSING="${MISSING} ${I}"
  1864.     fi
  1865. done
  1866. if test "${MISSING}" = "" ; then
  1867.     echo You have unpacked all 17 archives.
  1868.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1869. else
  1870.     echo You still must unpack the following archives:
  1871.     echo "        " ${MISSING}
  1872. fi
  1873. exit 0
  1874. exit 0 # Just in case...
  1875.