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