home *** CD-ROM | disk | FTP | other *** search
/ PC Online 1997 May / PCO_5_97.ISO / FilesBBS / OS2 / HTML_WIZ.ARJ / HTML_WIZ / HTMLWIZ.ZIP / HTMLWIZ / WEBLINT.CMD < prev   
Encoding:
Text File  |  1996-03-30  |  49.1 KB  |  1,693 lines
  1. extproc perl -x
  2. #!perl
  3.  
  4. #
  5. # weblint - pick fluff off WWW pages (html).
  6. #
  7. # Copyright (C) 1994, 1995 Neil Bowers.  All rights reserved.
  8. #
  9. # See README for additional blurb.
  10. # Bugs, comments, suggestions welcome: neilb@khoral.com
  11. #
  12. # Latest version is available as:
  13. #    ftp://ftp.khoral.com/pub/perl/www/weblint.tar.gz
  14. #
  15. $VERSION  = '1.011';
  16. ($PROGRAM = $0) =~ s@.*/@@;
  17. $TMPDIR   = $ENV{'TMPDIR'} || '/usr/tmp';
  18.  
  19. #------------------------------------------------------------------------
  20. # $usage - usage string displayed with the -U command-line switch
  21. #------------------------------------------------------------------------
  22. $usage=<<EofUsage;
  23.   $PROGRAM v$VERSION - pick fluff off web pages (HTML)
  24.       -d      : disable specified warnings (warnings separated by commas)
  25.       -e      : enable specified warnings (warnings separated by commas)
  26.       -stderr : print warnings to STDERR rather than STDOUT
  27.       -i      : ignore case in element tags
  28.       -l      : ignore symlinks when recursing in a directory
  29.       -s      : give short warning messages (filename not printed)
  30.       -t      : terse warning mode, useful mainly for the weblint testsuite
  31.       -todo   : print the todo list for $PROGRAM
  32.       -help
  33.       -U      : display this usage message
  34.       -urlget : specify the command used to get a URL
  35.       -version
  36.       -v      : display version
  37.       -warnings
  38.           : list supported warnings, with identifier, and enabled status
  39.       -x      : specify an HTML extension to include (supported: netscape)
  40.  
  41.   To check one or more HTML files, run weblint thusly:
  42.       weblint foobar.html
  43.       weblint file1.html ... fileN.html
  44.   If a file is in fact a directory, weblint will recurse, checking all files.
  45.  
  46.   To include the netscape extensions:
  47.       weblint -x netscape file.html
  48. EofUsage
  49.  
  50. #------------------------------------------------------------------------
  51. # $todo - ToDo string displayed with the -T command-line switch
  52. #------------------------------------------------------------------------
  53. $todo=<<EofToDo;
  54.                         $PROGRAM v$VERSION - ToDo list
  55.  
  56.     o    Verbose option to give longer warnings with example syntax.
  57.     o    build list of external links, for optional check at end.
  58.     o   check if any file in a directory hierarchy is not referenced.
  59.     o    Misuse of meta-characters, such as <, >, and ".
  60.         (Barry Bakalor <barry\@hal.com>)
  61.     o    check for http://foo.com/nar/tar.gz!
  62.     o    option to spell-check text (Clay Webster <clay\@unipress.com>)
  63.     o    option to specify level of HTML (0, 1, or 2)
  64.     o    option to understand server-side includes, e.g.:
  65.             <!inc srv "/Header.html">
  66.     o    entity checks (Axel Boldt).
  67.     o    a `pedantic' command-line switch, which turns on all warnings.
  68.     o    bad-link check gets confused if given a path with directories in it,
  69.     such as foo/bar/fred.html (Barry Bakalor)
  70.     o    SUB and SUP take one set of attributes in MATH mode, and
  71.         a different set when used outside MATH mode.
  72.     o    Use a DTD!
  73.     o    Option to spit out the HTML source annotated with SGML comments
  74.     which contain any weblint warnings. Tom Neff <tneff\@panix.com>
  75.     This will be: set message-style = inline -- neilb
  76.     o    Support for weblint directives in SGML comments.
  77.     Tom Neff <tneff\@panix.com>
  78.     o    A standardized "Weblint approved" snippet of HTML to put in pages.
  79.     This would also be a link to the weblint home page.
  80.     Tom Neff <tneff\@panix.com>
  81.     o    Flag places where use of <P> is redundant, and considered bad style;
  82.     such as following a <H?>.  See "Composing Good HTML".
  83.     o    Illegal context check, such as <P> appearing in <H1> ... </H1>
  84.     Jokinen Jyke <jyke\@cs.tut.fi>, Axel Boldt.
  85.     o    Check for existence of files with:
  86.         <IMG src="missing.gif" alt="Missing Image">
  87.         <BODY background="missing.gif">
  88.     as it already does with:
  89.         <A HREF="missing.html">missing thing</A>
  90.     (Barry Bakalor <barry\@hal.com>)
  91.     o    Give a more helpful message when <A NAME="..."> is not closed.
  92.     o    The following is legal HTML, but weblint complains:
  93.         <img alt = "> FOO <" src = "foo.gif">
  94.     Reported by Abigail <abigail\@mars.ic.iaf.nl>
  95.     o    Warn about leading and trailing whitespace in container contents,
  96.     at least for anchors:
  97.         <a href="url">  url </a>
  98.     Richard Finegold <goldfndr\@eskimo.com>
  99.     o    Add a warning which suggests you set WIDTH and HEIGHT on IMG
  100.     elements, since this can improved rendering time on some browsers.
  101.     Richard Finegold <goldfndr\@eskimo.com>
  102. EofToDo
  103.  
  104. *WARNING = *STDOUT;
  105.  
  106. # obsolete tags
  107. $obsoleteTags = 'PLAINTEXT|XMP|LISTING|COMMENT';
  108.  
  109. $maybePaired  = 'LI|DT|DD|P|ROW|TD|TH|TR';
  110.  
  111. $pairElements = 'A|ABBREV|ABOVE|ACRONYM|ADDRESS|ARRAY|AU|'.
  112.                 'HTML|HEAD|BANNER|BAR|BELOW|BIG|BLOCKQUOTE|BODY|BOX|BQ|BT|'.
  113.                 'CAPTION|CREDIT|DDOT|DEL|DIV|DOT|'.
  114.                 'FIG|FN|H1|H2|H3|H4|H5|H6|HAT|INS|LH|OVERLAY|'.
  115.         'B|I|U|TT|STRONG|EM|CODE|KBD|VAR|DFN|CITE|SAMP|Q|LANG|'.
  116.         'UL|OL|DL|'.
  117.                 'MATH|MENU|DIR|FORM|NOTE|PERSON|ROOT|'.
  118.                 'S|SELECT|SMALL|SQRT|STRIKE|STYLE|'.
  119.                 'SUB|SUP|T|TABLE|TEXT|TEXTAREA|TILDE|TITLE|VEC|CODE|PRE|'.
  120.                 $maybePaired.'|'.
  121.                 $obsoleteTags;
  122.  
  123. # expect to see these tags only once
  124. %onceOnly = ('HTML', 1, 'HEAD', 1, 'BODY', 1, 'TITLE', 1);
  125.  
  126. %physicalFontElements =
  127. (
  128.  'B',  'STRONG',
  129.  'I',  'EM',
  130.  'TT', 'CODE, SAMP, KBD, or VAR'
  131.  );
  132.  
  133. # expect these tags to have attributes
  134. # these are elements which have no required attributes, but we expect to
  135. # see at least one of the attributes
  136. $expectArgsRE = 'A';
  137.  
  138. # these tags can only appear in the head element
  139. $headTagsRE = 'TITLE|NEXTID|LINK|BASE|META';
  140.  
  141. %requiredContext =
  142. (
  143.  'ABOVE',     'MATH',
  144.  'ARRAY',     'MATH',
  145.  'ATOP',      'BOX',
  146.  'BAR',       'MATH',
  147.  'BELOW',     'MATH',
  148.  'BOX',       'MATH',
  149.  'BT',        'MATH',
  150.  'CAPTION',   'TABLE|FIG',
  151.  'CHOOSE',    'BOX',
  152.  'DD',        'DL',
  153.  'DDOT',      'MATH',
  154.  'DOT',       'MATH',
  155.  'DT',        'DL',
  156.  'HAT',       'MATH',
  157.  'INPUT',     'FORM',
  158.  'ITEM',      'ROW',
  159.  'LEFT',      'BOX',
  160.  'LH',        'DL|OL|UL',
  161.  'LI',        'DIR|MENU|OL|UL',
  162.  'OF',        'ROOT',
  163.  'OPTION',    'SELECT',
  164.  'OVER',      'BOX',
  165.  'OVERLAY',   'FIG',
  166.  'RIGHT',     'BOX',
  167.  'ROOT',      'MATH',
  168.  'ROW',       'ARRAY',
  169.  'SELECT',    'FORM',
  170.  'SQRT',      'MATH',
  171.  'T',         'MATH',
  172.  'TD',        'TR',
  173.  'TEXT',      'MATH',
  174.  'TEXTAREA',  'FORM',
  175.  'TH',        'TR',
  176.  'TILDE',     'MATH',
  177.  'TR',        'TABLE',
  178.  'VEC',       'MATH'
  179.  );
  180.  
  181. # these tags are allowed to appear in the head element
  182. %okInHead = ('ISINDEX', 1, 'TITLE', 1, 'NEXTID', 1, 'LINK', 1,
  183.          'BASE', 1, 'META', 1, 'RANGE', 1, 'STYLE', 1, '!--', 1);
  184.  
  185. # expect to see these at least once.
  186. # html-outer covers the HTML element
  187. @expectedTags = ('HEAD', 'TITLE', 'BODY');
  188.  
  189. # elements which cannot be nested
  190. $nonNest = 'A|FORM';
  191.  
  192. $netscapeElements = 'NOBR|WBR|FONT|BASEFONT|BLINK|CENTER';
  193.  
  194. #
  195. # This is a regular expression for all legal elements
  196. # UPDATE: need to remove duplication in legalElements and pairElements
  197. #
  198. $legalElements =
  199.    'A|ABBREV|ABOVE|ACRONYM|ADDRESS|ARRAY|ATOP|AU|'.
  200.    'B|BANNER|BAR|BASE|BELOW|BIG|BLOCKQUOTE|BODY|BOX|BQ|BR|BT|'.
  201.    'CAPTION|CHOOSE|CITE|CODE|CREDIT|'.
  202.    'DD|DDOT|DFN|DEL|DIR|DIV|DL|DOT|DT|'.
  203.    'EM|FIG|FN|FORM|H1|H2|H3|H4|H5|H6|HAT|HEAD|HR|HTML|'.
  204.    'I|IMG|INPUT|INS|ISINDEX|ITEM|KBD|'.
  205.    'LANG|LEFT|LH|LI|LINK|MATH|MENU|META|NEXTID|NOTE|'.
  206.    'OF|OL|OPTION|OVER|OVERLAY|P|PERSON|PRE|Q|RANGE|RIGHT|ROOT|ROW|'.
  207.    'SAMP|SELECT|S|SMALL|SQRT|STRIKE|STRONG|STYLE|SUB|SUP|'.
  208.    'T|TAB|TABLE|TD|TEXT|TEXTAREA|TH|TILDE|TITLE|TR|TT|U|UL|VAR|VEC|'.
  209.    $obsoleteTags;
  210.  
  211. # This table holds the valid attributes for elements
  212. # Where an element does not have an entry, this implies that the element
  213. # does not take any attributes
  214. %validAttributes =
  215.    (
  216.    'A',          'ID|LANG|CLASS|HREF|MD|NAME|SHAPE|TITLE|REL|REV',
  217.    'ABOVE',      'SYM',
  218.    'ADDRESS',    'ID|LANG|CLASS|CLEAR|NOWRAP',
  219.    'ARRAY',      'ALIGN|COLDEF|LDELIM|RDELIM|LABELS',
  220.    'BANNER',     'ID|LANG|CLASS',
  221.    'BASE',       'HREF',
  222.    'BR',         'ID|LANG|CLASS|CLEAR',
  223.    'BLOCKQUOTE', 'ID|LANG|CLASS|CLEAR|NOWRAP',
  224.    'BODY',       'ID|LANG|CLASS|BACKGROUND',
  225.    'BOX',        'SIZE',
  226.    'BQ',         'ID|LANG|CLASS|CLEAR|NOWRAP',
  227.    'BELOW',      'SYM',
  228.    'CAPTION',    'ID|LANG|CLASS|ALIGN',
  229.    'CREDIT',     'ID|LANG|CLASS',
  230.    'DD',         'ID|LANG|CLASS|CLEAR',
  231.    'DIV',        'ID|LANG|CLASS|ALIGN|NOWRAP|CLEAR',
  232.    'DL',         'ID|LANG|CLASS|CLEAR|COMPACT',
  233.    'DT',         'ID|LANG|CLASS|CLEAR',
  234.    'FIG',        'ID|LANG|CLASS|CLEAR|NOFLOW|SRC|MD|ALIGN|WIDTH|HEIGHT|'.
  235.                  'UNITS|IMAGEMAP',
  236.    'FN',         'ID|LANG|CLASS',
  237.    'FORM',       'ACTION|METHOD|ENCTYPE|SCRIPT',
  238.    'H1',         'ID|LANG|CLASS|ALIGN|CLEAR|SEQNUM|SKIP|DINGBAT|SRC|MD|NOWRAP',
  239.    'H2',         'ID|LANG|CLASS|ALIGN|CLEAR|SEQNUM|SKIP|DINGBAT|SRC|MD|NOWRAP',
  240.    'H3',         'ID|LANG|CLASS|ALIGN|CLEAR|SEQNUM|SKIP|DINGBAT|SRC|MD|NOWRAP',
  241.    'H4',         'ID|LANG|CLASS|ALIGN|CLEAR|SEQNUM|SKIP|DINGBAT|SRC|MD|NOWRAP',
  242.    'H5',         'ID|LANG|CLASS|ALIGN|CLEAR|SEQNUM|SKIP|DINGBAT|SRC|MD|NOWRAP',
  243.    'H6',         'ID|LANG|CLASS|ALIGN|CLEAR|SEQNUM|SKIP|DINGBAT|SRC|MD|NOWRAP',
  244.    'HR',         'ID|CLASS|CLEAR|SRC|MD',
  245.    'HTML',       'VERSION|URN|ROLE',
  246.    'IMG',        'ID|LANG|CLASS|SRC|MD|WIDTH|HEIGHT|UNITS|ALIGN|ALT|ISMAP',
  247.    'INPUT',      'ID|LANG|CLASS|TYPE|NAME|VALUE|DISABLED|ERROR|CHECKED|SIZE|'.
  248.                  'MAXLENGTH|MIN|MAX|ACCEPT|SRC|MD|ALIGN',
  249.    'ITEM',       'ALIGN|COLSPAN|ROWSPAN',
  250.    'LH',         'ID|LANG|CLASS',
  251.    'LI',         'ID|LANG|CLASS|CLEAR|SRC|MD|DINGBAT|SKIP',
  252.    'LINK',       'HREF|REL|REV|URN|TITLE|METHODS',
  253.    'MATH',       'ID|CLASS|BOX',
  254.    'META',       'HTTP-EQUIV|NAME|CONTENT',
  255.    'NEXTID',     'N',
  256.    'NOTE',       'ID|LANG|CLASS|CLEAR|SRC|MD',
  257.    'OL',         'ID|LANG|CLASS|CLEAR|CONTINUE|SEQNUM|COMPACT',
  258.    'OPTION',     'ID|LANG|CLASS|DISABLED|ERROR|VALUE|SELECTED|SHAPE',
  259.    'OVERLAY',    'SRC|MD|UNITS|X|Y|WIDTH|HEIGHT',
  260.    'P',          'ID|LANG|CLASS|ALIGN|CLEAR|NOWRAP',
  261.    'PRE',        'ID|LANG|CLASS|CLEAR|WIDTH',
  262.    'RANGE',      'ID|CLASS|FROM|UNTIL',
  263.    'ROW',        'ALIGN|COLSPAN|ROWSPAN',
  264.    'SELECT',     'ID|LANG|CLASS|NAME|MULTIPLE|DISABLED|ERROR|SRC|MD|WIDTH|'.
  265.                  'HEIGHT|UNITS|ALIGN',
  266.    'STYLE',      'NOTATION',
  267.    'TAB',        'ID|INDENT|TO|ALIGN|DP',
  268.    'TABLE',      'ID|LANG|CLASS|CLEAR|NOFLOW|ALIGN|UNITS|COLSPEC|DP|WIDTH|'.
  269.                  'BORDER|NOWRAP',
  270.    'TD',         'ID|LANG|CLASS|COLSPAN|ROWSPAN|ALIGN|DP|VALIGN|NOWRAP|'.
  271.                  'AXIS|AXES',
  272.    'TEXTAREA',   'ID|LANG|CLASS|NAME|ROWS|COLS|DISABLED|ERROR|ALIGN',
  273.    'TH',         'ID|LANG|CLASS|COLSPAN|ROWSPAN|ALIGN|DP|VALIGN|NOWRAP|'.
  274.                  'AXIS|AXES',
  275.    'TR',         'ID|LANG|CLASS|ALIGN|DP|VALIGN|NOWRAP',
  276.    'UL',         'ID|LANG|CLASS|CLEAR|PLAIN|SRC|MD|DINGBAT|WRAP|COMPACT',
  277.    );
  278.  
  279. %requiredAttributes =
  280.    (
  281.    'BASE',     'HREF',
  282.    'FORM',     'ACTION',
  283.    'IMG',      'SRC',
  284.    'LINK',     'HREF',
  285.    'NEXTID',   'N',
  286.    'SELECT',   'NAME',
  287.    'STYLE',    'NOTATION',
  288.    'TEXTAREA', 'NAME|ROWS|COLS'
  289.    );
  290.  
  291. %validNetscapeAttributes =
  292.    (
  293.    'ISINDEX',  'PROMPT',
  294.    'HR',       'SIZE|WIDTH|ALIGN|NOSHADE',
  295.    'UL',       'TYPE',
  296.    'OL',       'TYPE|START',
  297.    'LI',       'TYPE|VALUE',
  298.    'IMG',      'BORDER|VSPACE|HSPACE',
  299.    'BODY',     'BGCOLOR|TEXT|LINK|VLINK|ALINK',
  300.    'TABLE',    'CELLSPACING|CELLPADDING',
  301.    'TD',       'WIDTH',
  302.    'TH',       'WIDTH'
  303.    );
  304.  
  305. %mustFollow =
  306. (
  307.  'LH',       'UL|OL|DL',
  308.  'OVERLAY',  'FIG',
  309.  'HEAD',     'HTML',
  310.  'BODY',     '/HEAD',
  311.  '/HTML',    '/BODY',
  312.  );
  313.  
  314. %variable =
  315. (
  316.  'directory-index',    'index.html',
  317.  'url-get',        'lynx -source',
  318.  'message-style',    'lint'
  319. );
  320.  
  321. @options = ('d=s', 'e=s', 'stderr', 'help', 'i', 'l', 's', 't', 'todo', 'U',
  322.         'urlget=s', 'v', 'version', 'warnings', 'x=s');
  323.  
  324. $exit_status = 0;
  325.  
  326. #require 'newgetop.pl';
  327. #require 'find.pl';
  328.  
  329. die "$usage" unless @ARGV > 0;
  330.  
  331. &ReadDefaults();
  332. &GetConfigFile();
  333.  
  334. # escape the `-' command-line switch (for stdin), so NGetOpt don't mess wi' it
  335. grep(s/^-$/\tstdin\t/, @ARGV);
  336.  
  337. &NGetOpt(@options) || die "use -U switch to display usage statement\n";
  338.  
  339. # put back the `-' command-line switch, if it was there
  340. grep(s/^\tstdin\t$/-/, @ARGV);
  341.  
  342. die "$PROGRAM v$VERSION\n"            if $opt_v || $opt_version;
  343. die "$usage"                          if $opt_u || $opt_help;
  344. die "$todo"                           if $opt_todo;
  345. &AddExtension($opt_x)                 if $opt_x;
  346. $variable{'message-style'} = 'short'  if $opt_s;
  347. $variable{'message-style'} = 'terse'  if $opt_t;
  348. $variable{'url-get'} = $opt_urlget   if $opt_urlget;
  349. *WARNING = *STDERR                    if $opt_stderr;
  350. &ListWarnings()                      if $opt_warnings;
  351.  
  352. # WARNING file handle is default
  353. select(WARNING);
  354.  
  355. $opt_l = 1                 if $ignore{'SYMLINKS'};
  356.  
  357. # -d to disable warnings
  358. if ($opt_d)
  359. {
  360.    for (split(/,/,$opt_d))
  361.    {
  362.       &enableWarning($_, 0);
  363.    }
  364. }
  365.  
  366. # -e to enable warnings
  367. if ($opt_e)
  368. {
  369.    for (split(/,/,$opt_e))
  370.    {
  371.       &enableWarning($_, 1) || next;
  372.    }
  373. }
  374.  
  375. # -i option to ignore case in element tags
  376. if ($opt_i)
  377. {
  378.    $enabled{'lower-case'} = $enabled{'upper-case'} = 0;
  379. }
  380.  
  381. while (@ARGV > 0)
  382. {
  383.    $arg = shift(@ARGV);
  384.  
  385.    &CheckURL($arg), next if $arg =~ m!^(http|gopher|ftp)://!;
  386.  
  387.    &find($arg), next if -d $arg;
  388.  
  389.    &WebLint($arg), next if (-f $arg && -r $arg) || $arg eq '-';
  390.  
  391.    print "$PROGRAM: could not read $arg: $!\n";
  392. }
  393.  
  394. exit $exit_status;
  395.  
  396. #========================================================================
  397. # Function:    WebLint
  398. # Purpose:    This is the high-level interface to the checker.  It takes
  399. #        a file and checks for fluff.
  400. #========================================================================
  401. sub WebLint
  402. {
  403.    local($filename,$relpath) = @_;
  404.    local(@tags) = ();
  405.    local($tagRE) = ('');
  406.    local(@taglines) = ();
  407.    local(@orphans) = ();
  408.    local(@orphanlines) = ();
  409.    local(%seenPage);
  410.    local(%seenTag);
  411.    local(%whined);
  412.    local(*PAGE);
  413.    local($line) = ('');
  414.    local($id, $ID);
  415.    local($tag);
  416.    local($closing);
  417.    local($tail);
  418.    local(%args);
  419.    local($arg);
  420.    local($rest);
  421.    local($lastNonTag);
  422.    local(@notSeen);
  423.    local($seenMailtoLink) = (0);
  424.    local($matched);
  425.    local($matchedLine);
  426.    local($novalue);
  427.    local($heading);
  428.    local($headingLine);
  429.    local($commentline);
  430.    local($_);
  431.  
  432.  
  433.    if ($filename eq '-')
  434.    {
  435.       *PAGE = *STDIN;
  436.       $filename = 'stdin';
  437.    }
  438.    else
  439.    {
  440.       return if defined $seenPage{$filename};
  441.       if (-d $filename)
  442.       {
  443.      print "$PROGRAM: $filename is a directory.\n";
  444.      $exit_status = 0;
  445.      return;
  446.       }
  447.       $seenPage{$filename}++;
  448.       open(PAGE,"<$filename") || do
  449.       {
  450.      print "$PROGRAM: could not read file $filename: $!\n";
  451.      $exit_status = 0;
  452.      return;
  453.       };
  454.       $filename = $relpath if defined $relpath;
  455.    }
  456.  
  457.    undef $heading;
  458.  
  459.  READLINE:
  460.    while (<PAGE>)
  461.    {
  462.       $line .= $_;
  463.       $line =~ s/\n/ /g;
  464.  
  465.       while ($line =~ /</o)
  466.       {
  467.      $tail = $'; #'
  468.      undef $lastNonTag;
  469.      $lastNonTag = $` if $` !~ /^\s*$/o;
  470.  
  471.      #--------------------------------------------------------
  472.      #== SGML comment: <!-- ... blah blah ... -->
  473.      #--------------------------------------------------------
  474.      if ($tail =~ /^!--/o)
  475.      {
  476.  
  477.         $commentline = $. unless defined $commentline;
  478.  
  479.         # push lastNonTag onto word list for spell checking
  480.  
  481.         $ct = $';
  482.         next READLINE unless $ct =~ /--\s*>/o;
  483.  
  484.         undef $commentline;
  485.  
  486.         $comment = $`;
  487.         $line = $';
  488.  
  489.         # markup embedded in comment can confuse some (most? :-) browsers
  490.         &whine($., 'markup-in-comment') if $comment =~ /<\s*[^>]+>/o;
  491.         next;
  492.      }
  493.      undef $commentline;
  494.  
  495.      next READLINE unless $tail =~ /^(\s*)([^>]*)>/;
  496.  
  497.  
  498.      &whine($., 'leading-whitespace', $2) if $1 ne '';
  499.  
  500.          $id = $tag = $2;
  501.          $line = $';
  502.  
  503.          &whine($., 'unknown-element', $id),next if $id =~ /^\s*$/;
  504.  
  505.      # push lastNonTag onto word list for spell checking
  506.  
  507.          undef $tail;
  508.          undef $closing;
  509.          undef %args;
  510.  
  511.          #-- <!DOCTYPE ... > is ignored for now.
  512.          next if $id =~ /^!doctype/io;
  513.  
  514.      $closing = 0;
  515.          if ($id =~ m@^/@o)
  516.          {
  517.             $id =~ s@^/@@;
  518.         $ID = "\U$id";
  519.             $closing = 1;
  520.          }
  521.  
  522.          #--------------------------------------------------------
  523.          #== some seriously ugly code to handle attributes ...
  524.          #--------------------------------------------------------
  525.      if ($closing == 0 && $tag =~ m|^(\S+)\s+(.*)|)
  526.          {
  527.             ($id,$tail) = ($1,$2);
  528.         $ID = "\U$id";
  529.         $tail =~ s/\n/ /g;
  530.  
  531.             # check for odd number of quote characters
  532.             ($quotes = $tail) =~ s/[^"]//g;
  533.             &whine($., 'odd-quotes', $tag) if length($quotes) % 2 == 1;
  534.  
  535.         $novalue = 0;
  536.         $valid = $validAttributes{$ID};
  537.         while ($tail =~ /^\s*([^=\s]+)\s*=\s*(.*)$/
  538.            # catch attributes like ISMAP for IMG, with no arg
  539.            || ($tail =~ /^\s*(\S+)(.*)/ && ($novalue = 1)))
  540.         {
  541.            $arg = "\U$1";
  542.            $rest = $2;
  543.  
  544.                &whine($., 'unexpected-open', $tag) if $arg =~ /</;
  545.  
  546.            if ($arg !~ /^($valid)$/i && $ID =~ /^($legalElements)$/o)
  547.            {
  548.           if ($arg =~ /^($validNetscapeAttributes{$ID})$/i)
  549.           {
  550.              &whine($., 'netscape-attribute', $arg, $id);
  551.           }
  552.           else
  553.           {
  554.              &whine($., 'unknown-attribute', $id, $arg);
  555.           }
  556.            }
  557.  
  558.                #-- catch repeated attributes.  for example:
  559.                #--     <IMG SRC="foo.gif" SRC="bar.gif">
  560.                if (defined $args{$arg})
  561.                {
  562.                   &whine($., 'repeated-attribute', $arg, $id);
  563.                }
  564.  
  565.            if ($novalue)
  566.            {
  567.           $args{$arg} = '';
  568.           $tail = $rest;
  569.            }
  570.            elsif ($rest =~ /^'([^']+)'(.*)$/)
  571.                {
  572.           &whine($., 'attribute-delimiter', $arg, $ID);
  573.                   $args{$arg} = $1;
  574.                   $tail = $2;
  575.                }
  576.            elsif ($rest =~ /^"([^"]+)"(.*)$/
  577.               || $rest =~ /^'([^']+)'(.*)$/
  578.               || $rest =~ /^(\S+)(.*)$/)
  579.                {
  580.                   $args{$arg} = $1;
  581.                   $tail = $2;
  582.                }
  583.                else
  584.                {
  585.                   $args{$arg} = $rest;
  586.                   $tail = '';
  587.                }
  588.            $novalue = 0;
  589.             }
  590.         &whine($., 'unexpected-open', $tag) if $tail =~ /</o;
  591.          }
  592.      else
  593.      {
  594.             if ($closing && $id =~ m|^(\S+)\s+(.*)|)
  595.             {
  596.            &whine($., 'closing-attribute', $tag);
  597.            $id = $1;
  598.             }
  599.         $ID = "\U$id";
  600.      }
  601.  
  602.      $TAG = ($closing ? "/" : "").$ID;
  603.      if (defined $mustFollow{$TAG})
  604.      {
  605.         $ok = 0;
  606.         foreach $pre (split(/\|/, $mustFollow{$TAG}))
  607.         {
  608.            ($ok=1),last if $pre eq $lastTAG;
  609.         }
  610.         if (!$ok || $lastNonTag !~ /^\s*$/)
  611.         {
  612.            &whine($., 'must-follow', $TAG, $mustFollow{$TAG});
  613.         }
  614.      }
  615.  
  616.      #-- catch empty container elements
  617.      if ($closing && $ID eq $lastTAG && $lastNonTag =~ /^\s*$/
  618.          && $ID ne 'TEXTAREA')
  619.      {
  620.         &whine($., 'empty-container', $ID);
  621.      }
  622.  
  623.      #-- special case for empty optional container elements
  624.      if (!$closing && $ID eq $tags[$#tags] && $lastTAG eq $ID
  625.          && $ID =~ /^($maybePaired)$/
  626.          && $lastNonTag =~ /^\s*$/)
  627.      {
  628.         $t = pop @tags;
  629.         $tline = pop @taglines;
  630.         &whine($tline, 'empty-container', $ID);
  631.         $tagRE = join('|',@tags);
  632.      }
  633.  
  634.          #-- whine about unrecognized element, and do no more checks ----
  635.          if ($id !~ /^($legalElements)$/io)
  636.      {
  637.         if ($id =~ /^($netscapeElements)$/io)
  638.         {
  639.            &whine($., 'netscape-markup', ($closing ? "/$id" : "$id"));
  640.         }
  641.         else
  642.         {
  643.            &whine($., 'unknown-element', ($closing ? "/$id" : "$id"));
  644.         }
  645.         next;
  646.      }
  647.  
  648.          if ($closing == 0 && defined $requiredAttributes{$ID})
  649.          {
  650.         @argkeys = keys %args;
  651.         foreach $attr (split(/\|/,$requiredAttributes{$ID}))
  652.         {
  653.            unless (defined $args{$attr})
  654.            {
  655.           &whine($., 'required-attribute', $attr, $id);
  656.            }
  657.         }
  658.          }
  659.          elsif ($closing == 0 && $id =~ /^($expectArgsRE)$/io)
  660.          {
  661.             &whine($., 'expected-attribute', $id) unless defined %args;
  662.          }
  663.  
  664.          #--------------------------------------------------------
  665.          #== check case of tags
  666.          #--------------------------------------------------------
  667.          &whine($., 'upper-case', $id) if $id ne $ID;
  668.          &whine($., 'lower-case', $id) if $id ne "\L$id";
  669.  
  670.  
  671.          #--------------------------------------------------------
  672.          #== if tag id is /foo, then strip slash, and mark as a closer
  673.          #--------------------------------------------------------
  674.          if ($closing)
  675.          {
  676.         if ($ID !~ /^($pairElements)$/o)
  677.         {
  678.            &whine($., 'illegal-closing', $id);
  679.         }
  680.  
  681.             if ($ID eq 'A' && $lastNonTag =~ /^\s*here\s*$/io)
  682.             {
  683.                &whine($., 'here-anchor');
  684.             }
  685.  
  686.         #-- end of HEAD, did we see a TITLE in the HEAD element? ----
  687.         &whine($., 'require-head') if $ID eq 'HEAD' && !$seenTag{'TITLE'};
  688.  
  689.         #-- was there a <LINK REV=MADE HREF="mailto:.."> element in HEAD?
  690.         &whine($., 'mailto-link') if $ID eq 'HEAD' && $seenMailtoLink == 0;
  691.          }
  692.          else
  693.          {
  694.             #--------------------------------------------------------
  695.             # do context checks.  Should really be a state machine.
  696.             #--------------------------------------------------------
  697.  
  698.         if (defined $physicalFontElements{$ID})
  699.         {
  700.            &whine($., 'physical-font', $ID, $physicalFontElements{$ID});
  701.         }
  702.  
  703.             if ($ID eq 'A' && defined $args{'HREF'})
  704.             {
  705.            $target = $args{'HREF'};
  706.                if ($target =~ /([^:]+):\/\/([^\/]+)(.*)$/
  707.            || $target =~ /^(news|mailto):/
  708.            || $target =~ /^\//)
  709.                {
  710.                }
  711.                else
  712.                {
  713.           $target =~ s/#.*$//;
  714.           if ($target !~ /^\s*$/ && ! -f $target && ! -d $target)
  715.           {
  716.              &whine($., 'bad-link', $target);
  717.           }
  718.                }
  719.             }
  720.  
  721.             if ($ID =~ /^H(\d)$/o)
  722.         {
  723.                if (defined $heading && $1 - $heading > 1)
  724.                {
  725.               &whine($., 'heading-order', $ID, $heading, $headingLine);
  726.                }
  727.                $heading     = $1;
  728.                $headingLine = $.;
  729.         }
  730.  
  731.         #-- check for mailto: LINK ------------------------------
  732.         if ($ID eq 'LINK' && $args{'REV'} =~ /^made$/io
  733.         && $args{'HREF'} =~ /^mailto:/io)
  734.         {
  735.            $seenMailtoLink = 1;
  736.         }
  737.  
  738.         if (defined $onceOnly{$ID})
  739.         {
  740.            &whine($., 'once-only', $ID, $seenTag{$ID}) if $seenTag{$ID};
  741.         }
  742.             $seenTag{$ID} = $.;
  743.  
  744.             &whine($., 'body-no-head') if $ID eq 'BODY' && !$seenTag{'HEAD'};
  745.  
  746.             if ($ID ne 'HTML' && $ID ne '!DOCTYPE' && !$seenTag{'HTML'}
  747.                 && !$whined{'outer-html'})
  748.             {
  749.                &whine($., 'html-outer');
  750.                $whined{'outer-html'} = 1;
  751.             }
  752.  
  753.         #-- check for illegally nested elements ---------------------
  754.         if ($ID =~ /^($nonNest)$/o && $ID =~ /^($tagRE)$/)
  755.         {
  756.            for ($i=$#tags; $tags[$i] ne $ID; --$i)
  757.            {
  758.            }
  759.            &whine($., 'nested-element', $ID, $taglines[$i]);
  760.         }
  761.  
  762.         &whine($., 'unknown-element', $ID) unless $ID =~ /^($legalElements)$/o;
  763.  
  764.         #--------------------------------------------------------
  765.         # check for tags which have a required context
  766.         #--------------------------------------------------------
  767.         if (defined ($reqCon = $requiredContext{$ID}))
  768.         {
  769.            $ok = 0;
  770.            foreach $context (split(/\|/, $requiredContext{$ID}))
  771.            {
  772.           ($ok=1),last if $context =~ /^($tagRE)$/;
  773.            }
  774.            unless ($ok)
  775.            {
  776.                   &whine($., 'required-context', $ID, $requiredContext{$ID});
  777.            }
  778.         }
  779.  
  780.         #--------------------------------------------------------
  781.         # check for tags which can only appear in the HEAD element
  782.         #--------------------------------------------------------
  783.         if ($ID =~ /^($headTagsRE)$/o && 'HEAD' !~ /^($tagRE)$/)
  784.         {
  785.                &whine($., 'head-element', $ID);
  786.         }
  787.  
  788.         if (! defined $okInHead{$ID} && 'HEAD' =~ /^($tagRE)$/)
  789.         {
  790.                &whine($., 'non-head-element', $ID);
  791.         }
  792.  
  793.         #--------------------------------------------------------
  794.         # check for tags which have been deprecated (now obsolete)
  795.         #--------------------------------------------------------
  796.         &whine($., 'obsolete', $ID) if $ID =~ /^($obsoleteTags)$/o;
  797.          }
  798.  
  799.          #--------------------------------------------------------
  800.          #== was tag of type <TAG> ... </TAG>?
  801.          #== welcome to kludgeville, population seems to be on the increase!
  802.          #--------------------------------------------------------
  803.          if ($ID =~ /^($pairElements)$/o)
  804.          {
  805.         #-- if we have a closing tag, and the tag(s) on top of the stack
  806.         #-- are optional closing tag elements, pop the tag off the stack,
  807.         #-- unless it matches the current closing tag
  808.         if ($closing)
  809.         {
  810.            while (@tags > 0 && $tags[$#tags] ne $ID
  811.               && $tags[$#tags] =~ /^($maybePaired)$/o)
  812.            {
  813.           pop @tags;
  814.           pop @taglines;
  815.            }
  816.            $tagRE = join('|',@tags);
  817.         }
  818.  
  819.             if ($closing && $tags[$#tags] eq $ID)
  820.             {
  821.                $matched     = pop @tags;
  822.                $matchedLine = pop @taglines;
  823.  
  824.            #-- does top of stack match top of orphans stack? --------
  825.            while (@orphans > 0 && @tags > 0
  826.            && $orphans[$#orphans] eq $tags[$#tags])
  827.            {
  828.           &whine($., 'element-overlap', $orphans[$#orphans],
  829.              $orphanlines[$#orphanlines], $matched, $matchedLine);
  830.           pop @orphans;
  831.           pop @orphanlines;
  832.           pop @tags;
  833.           pop @taglines;
  834.            }
  835.                $tagRE = join('|',@tags);
  836.             }
  837.             elsif ($closing && $tags[$#tags] ne $ID)
  838.             {
  839.            #-- closing tag does not match opening tag on top of stack
  840.            if ($ID =~ /^($tagRE)$/)
  841.            {
  842.           # If we saw </HTML>, </HEAD>, or </BODY>, then we try
  843.           # and resolve anything inbetween on the tag stack
  844.           if ($ID =~ /^(HTML|HEAD|BODY)$/o)
  845.           {
  846.              while ($tags[$#tags] ne $ID)
  847.              {
  848.             $ttag = pop @tags;
  849.             $ttagline = pop @taglines;
  850.             if ($ttag !~ /^($maybePaired)$/)
  851.             {
  852.                &whine($., 'unclosed-element', $ttag, $ttagline);
  853.             }
  854.  
  855.             #-- does top of stack match top of orphans stack? --
  856.             while (@orphans > 0 && @tags > 0
  857.                    && $orphans[$#orphans] eq $tags[$#tags])
  858.             {
  859.                pop @orphans;
  860.                pop @orphanlines;
  861.                pop @tags;
  862.                pop @taglines;
  863.             }
  864.              }
  865.  
  866.              #-- pop off the HTML, HEAD, or BODY tag ------------
  867.              pop @tags;
  868.              pop @taglines;
  869.              $tagRE = join('|',@tags);
  870.           }
  871.           else
  872.           {
  873.              #-- matched opening tag lower down on stack
  874.              push(@orphans, $ID);
  875.              push(@orphanlines, $.);
  876.           }
  877.            }
  878.            else
  879.            {
  880.           &whine($., 'mis-match', $ID);
  881.            }
  882.             }
  883.             else
  884.             {
  885.                push(@tags,$ID);
  886.                $tagRE = join('|',@tags);
  887.                push(@taglines,$.);
  888.             }
  889.          }
  890.  
  891.          #--------------------------------------------------------
  892.          #== inline images (IMG) should have an ALT argument :-)
  893.          #--------------------------------------------------------
  894.          &whine($., 'img-alt') if ($ID eq 'IMG'
  895.                    && !defined $args{'ALT'}
  896.                    && !$closing);
  897.  
  898.       } continue {
  899.          $lastTAG = $TAG;
  900.       }
  901.       $lastNonTag = $line;
  902.    }
  903.    close PAGE;
  904.  
  905.    if (defined $commentline)
  906.    {
  907.       &whine($commentline, 'unclosed-comment');
  908.       return;
  909.    }
  910.  
  911.    while (@tags > 0)
  912.    {
  913.       $tag = shift(@tags);
  914.       $line = shift(@taglines);
  915.       if ($tag !~ /^($maybePaired)$/)
  916.       {
  917.      &whine($., 'unclosed-element', $tag, $line);
  918.       }
  919.    }
  920.  
  921.    for (@expectedTags)
  922.    {
  923.       # if we haven't seen TITLE but have seen HEAD
  924.       # then we'll have already whined about the lack of a TITLE element
  925.       next if $_ eq 'TITLE' && !$seenTag{$_} && $seenTag{'HEAD'};
  926.       push(@notSeen,$_) unless $seenTag{$_};
  927.    }
  928.    if (@notSeen > 0)
  929.    {
  930.       printf ("%sexpected tag(s) not seen: @notSeen\n",
  931.               ($opt_s ? "" : "$filename(-): "));
  932.       $exit_status = 1;
  933.    }
  934. }
  935.  
  936. #========================================================================
  937. # Function:    whine
  938. # Purpose:    Give a standard format whine:
  939. #            filename(line #): <message>
  940. #               The associative array `enabled' is used as a gating
  941. #               function, to suppress or enable each warning.  Every
  942. #               warning has an associated identifier, which is used to
  943. #               refer to the warning, and as the index into the hash.
  944. #========================================================================
  945. sub whine
  946. {
  947.    local($line, $id, @argv) = @_;
  948.    local($mstyle)        = $variable{'message-style'};
  949.  
  950.  
  951.    return unless $enabled{$id};
  952.    $exit_status = 1;
  953.    (print "$filename:$line:$id\n"), return             if $mstyle eq 'terse';
  954.    (eval "print \"$filename($line): $message{$id}\n\""), return if $mstyle eq 'lint';
  955.    (eval "print \"line $line: $message{$id}\n\""), return if $mstyle eq 'short';
  956.  
  957.    die "Unknown message style `$mstyle'\n";
  958. }
  959.  
  960. #========================================================================
  961. # Function:    GetConfigFile
  962. # Purpose:    Read user's configuration file, if such exists.
  963. #               If WEBLINTRC is set in user's environment, then read the
  964. #               file referenced, otherwise try for $HOME/.weblintrc.
  965. #========================================================================
  966. sub GetConfigFile
  967. {
  968.    local(*CONFIG);
  969.    local($filename);
  970.    local($arglist);
  971.    local($value);
  972.  
  973.  
  974.    $filename = $ENV{'WEBLINTRC'} || "$ENV{'HOME'}/.weblintrc";
  975.    return unless -f $filename;
  976.  
  977.    open(CONFIG,"< $filename") || do
  978.    {
  979.       print WARNING "Unable to read config file `$filename': $!\n";
  980.       return 0;
  981.    };
  982.  
  983.    while (<CONFIG>)
  984.    {
  985.       s/#.*$//;
  986.       next if /^\s*$/o;
  987.  
  988.       #-- match keyword: process one or more argument -------------------
  989.       if (/^\s*(enable|disable|extension|ignore)\s+(.*)$/io)
  990.       {
  991.      $keyword = "\U$1";
  992.      $arglist = $2;
  993.      while ($arglist =~ /^\s*(\S+)/o)
  994.      {
  995.         $value = "\L$1";
  996.  
  997.         &enableWarning($1, 1) if $keyword eq 'ENABLE';
  998.  
  999.         &enableWarning($1, 0) if $keyword eq 'DISABLE';
  1000.  
  1001.         $ignore{"\U$1"} = 1 if $keyword eq 'IGNORE';
  1002.  
  1003.         &AddExtension($1) if $keyword eq 'EXTENSION';
  1004.  
  1005.         $arglist = $';
  1006.      }
  1007.       }
  1008.       elsif (/^\s*set\s+(\S+)\s*=\s*(.*)/)
  1009.       {
  1010.          # setting a weblint variable
  1011.          if (defined $variable{$1})
  1012.          {
  1013.             $variable{$1} = $2;
  1014.          }
  1015.          else
  1016.          {
  1017.             print WARNING "Unknown variable `$1' in configuration file\n"
  1018.          }
  1019.       }
  1020.    }
  1021.  
  1022.    close CONFIG;
  1023.  
  1024.    1;
  1025. }
  1026.  
  1027. sub enableWarning
  1028. {
  1029.    local($id, $enabled) = @_;
  1030.  
  1031.  
  1032.    if (! defined $enabled{$id})
  1033.    {
  1034.       print WARNING "$PROGRAM: unknown warning identifier \"$id\"\n";
  1035.       return 0;
  1036.    }
  1037.  
  1038.    $enabled{$id} = $enabled;
  1039.  
  1040.    #
  1041.    # ensure consistency: if you just enabled upper-case,
  1042.    # then we should make sure that lower-case is disabled
  1043.    #
  1044.    $enabled{'lower-case'} = 0 if $_ eq 'upper-case';
  1045.    $enabled{'upper-case'} = 0 if $_ eq 'lower-case';
  1046.    $enabled{'upper-case'} = $enabled{'lower-case'} = 0 if $_ eq 'mixed-case';
  1047.  
  1048.    return 1;
  1049. }
  1050.  
  1051. #========================================================================
  1052. # Function:    AddExtension
  1053. # Purpose:    Extend the HTML understood.  Currently supported extensions:
  1054. #            netscape  - the netscape extensions proposed by
  1055. #                                   Netscape Communications, Inc.  See:
  1056. #               http://www.netscape.com/home/services_docs/html-extensions.html
  1057. #========================================================================
  1058. sub AddExtension
  1059. {
  1060.    local($extension) = @_;
  1061.  
  1062.    if ("\L$extension" ne 'netscape')
  1063.    {
  1064.       warn "$PROGRAM: unknown extension `$extension' -- ignoring.\n";
  1065.       return;
  1066.    }
  1067.  
  1068.    #---------------------------------------------------------------------
  1069.    # netscape extensions
  1070.    #---------------------------------------------------------------------
  1071.  
  1072.    #-- new element attributes for existing elements ---------------------
  1073.  
  1074.    &AddAttributes('ISINDEX',  'PROMPT');
  1075.    &AddAttributes('HR',       'SIZE', 'WIDTH', 'ALIGN', 'NOSHADE');
  1076.    &AddAttributes('UL',       'TYPE');
  1077.    &AddAttributes('OL',       'TYPE', 'START');
  1078.    &AddAttributes('LI',       'TYPE', 'VALUE');
  1079.    &AddAttributes('IMG',      'BORDER', 'VSPACE', 'HSPACE');
  1080.    &AddAttributes('BODY',     'BGCOLOR', 'TEXT', 'LINK', 'VLINK', 'ALINK');
  1081.    &AddAttributes('TABLE',    'CELLSPACING', 'CELLPADDING');
  1082.    &AddAttributes('TD',       'WIDTH');
  1083.    &AddAttributes('TH',       'WIDTH');
  1084.  
  1085.    #-- new elements -----------------------------------------------------
  1086.  
  1087.    $legalElements .= '|'.$netscapeElements;
  1088.    $pairElements  .= '|BLINK|CENTER|FONT|NOBR';
  1089.    &AddAttributes('FONT',     'SIZE');
  1090.    &AddAttributes('BASEFONT', 'SIZE');
  1091. }
  1092.  
  1093. sub AddAttributes
  1094. {
  1095.    local($element,@attributes) = @_;
  1096.    local($attr);
  1097.  
  1098.  
  1099.    $attr = join('|', @attributes);
  1100.    if (defined $validAttributes{$element})
  1101.    {
  1102.       $validAttributes{$element} .= "|$attr";
  1103.    }
  1104.    else
  1105.    {
  1106.       $validAttributes{$element} = "$attr";
  1107.    }
  1108. }
  1109.  
  1110. #========================================================================
  1111. # Function:    ListWarnings()
  1112. # Purpose:    List all supported warnings, with identifier, and
  1113. #        whether the warning is enabled.
  1114. #========================================================================
  1115. sub ListWarnings
  1116. {
  1117.    local($id);
  1118.    local($message);
  1119.  
  1120.  
  1121.    foreach $id (sort keys %enabled)
  1122.    {
  1123.       ($message = $message{$id}) =~ s/\$argv\[\d+\]/.../g;
  1124.       $message =~ s/\\"/"/g;
  1125.       print WARNING "$id (", ($enabled{$id} ? "enabled" : "disabled"), ")\n";
  1126.       print WARNING "    $message\n\n";
  1127.    }
  1128. }
  1129.  
  1130. sub CheckURL
  1131. {
  1132.    local($url)        = @_;
  1133.    local($workfile)    = "$TMPDIR/$PROGRAM.$$";
  1134.    local($urlget)    = $variable{'url-get'};
  1135.  
  1136.  
  1137.    die "$PRORGAM: url-get variable is not defined -- ".
  1138.        "don't know how to get $url\n" unless defined $urlget;
  1139.  
  1140.    system("$urlget $url > $workfile");
  1141.    &WebLint($workfile, $url);
  1142.    unlink $workfile;
  1143. }
  1144.  
  1145. #========================================================================
  1146. # Function:    wanted
  1147. # Purpose:    This is called by &find() to determine whether a file
  1148. #               is wanted.  We're looking for files, with the filename
  1149. #               extension .html or .htm.
  1150. #========================================================================
  1151. sub wanted
  1152. {
  1153.    if (-d $_ && ! -f "$_/$variable{'directory-index'}")
  1154.    {
  1155.       &whine('*', 'directory-index', "$arg/$_", $variable{'directory-index'});
  1156.    }
  1157.  
  1158.    /\.(html|htm)$/ &&        # valid filename extensions: .html .htm
  1159.       -f $_ &&            # only looking for files
  1160.       (!$opt_l || !-l $_) &&    # ignore symlinks if -l given
  1161.       &WebLint($_,$name);    # check the file
  1162. }
  1163.  
  1164. #========================================================================
  1165. # Function:    ReadDefaults
  1166. # Purpose:    Read the built-in defaults.  These are stored at the end
  1167. #               of the script, after the __END__, and read from the
  1168. #               DATA filehandle.
  1169. #========================================================================
  1170. sub ReadDefaults
  1171. {
  1172.    local(@elements);
  1173.  
  1174.  
  1175.    while (<DATA>)
  1176.    {
  1177.       chop;
  1178.       s/^\s*//;
  1179.       next if /^$/;
  1180.  
  1181.       push(@elements, $_);
  1182.  
  1183.       next unless @elements == 3;
  1184.  
  1185.       ($id, $default, $message) = @elements;
  1186.       $enabled{$id} = ($default eq 'ENABLE');
  1187.       ($message{$id} = $message) =~ s/"/\\"/g;
  1188.       undef @elements;
  1189.    }
  1190. }
  1191.  
  1192.  
  1193.  
  1194. # newgetopt.pl -- new options parsing
  1195.  
  1196. # SCCS Status     : @(#)@ newgetopt.pl    1.13
  1197. # Author          : Johan Vromans
  1198. # Created On      : Tue Sep 11 15:00:12 1990
  1199. # Last Modified By: Johan Vromans
  1200. # Last Modified On: Tue Jun  2 11:24:03 1992
  1201. # Update Count    : 75
  1202. # Status          : Okay
  1203.  
  1204. # This package implements a new getopt function. This function adheres
  1205. # to the new syntax (long option names, no bundling).
  1206. #
  1207. # Arguments to the function are:
  1208. #
  1209. #  - a list of possible options. These should designate valid perl
  1210. #    identifiers, optionally followed by an argument specifier ("="
  1211. #    for mandatory arguments or ":" for optional arguments) and an
  1212. #    argument type specifier: "n" or "i" for integer numbers, "f" for
  1213. #    real (fix) numbers or "s" for strings.
  1214. #    If an "@" sign is appended, the option is treated as an array.
  1215. #    Value(s) are not set, but pushed.
  1216. #
  1217. #  - if the first option of the list consists of non-alphanumeric
  1218. #    characters only, it is interpreted as a generic option starter.
  1219. #    Everything starting with one of the characters from the starter
  1220. #    will be considered an option.
  1221. #    Likewise, a double occurrence (e.g. "--") signals end of
  1222. #    the options list.
  1223. #    The default value for the starter is "-", "--" or "+".
  1224. #
  1225. # Upon return, the option variables, prefixed with "opt_", are defined
  1226. # and set to the respective option arguments, if any.
  1227. # Options that do not take an argument are set to 1. Note that an
  1228. # option with an optional argument will be defined, but set to '' if
  1229. # no actual argument has been supplied.
  1230. # A return status of 0 (false) indicates that the function detected
  1231. # one or more errors.
  1232. #
  1233. # Special care is taken to give a correct treatment to optional arguments.
  1234. #
  1235. # E.g. if option "one:i" (i.e. takes an optional integer argument),
  1236. # then the following situations are handled:
  1237. #
  1238. #    -one -two        -> $opt_one = '', -two is next option
  1239. #    -one -2        -> $opt_one = -2
  1240. #
  1241. # Also, assume "foo=s" and "bar:s" :
  1242. #
  1243. #    -bar -xxx        -> $opt_bar = '', '-xxx' is next option
  1244. #    -foo -bar        -> $opt_foo = '-bar'
  1245. #    -foo --        -> $opt_foo = '--'
  1246. #
  1247. # HISTORY 
  1248. # 2-Jun-1992        Johan Vromans    
  1249. #    Do not use //o to allow multiple NGetOpt calls with different delimeters.
  1250. #    Prevent typeless option from using previous $array state.
  1251. #    Prevent empty option from being eaten as a (negative) number.
  1252.  
  1253. # 25-May-1992        Johan Vromans    
  1254. #    Add array options. "foo=s@" will return an array @opt_foo that
  1255. #    contains all values that were supplied. E.g. "-foo one -foo -two" will
  1256. #    return @opt_foo = ("one", "-two");
  1257. #    Correct bug in handling options that allow for a argument when followed
  1258. #    by another option.
  1259.  
  1260. # 4-May-1992        Johan Vromans    
  1261. #    Add $ignorecase to match options in either case.
  1262. #    Allow '' option.
  1263.  
  1264. # 19-Mar-1992        Johan Vromans    
  1265. #    Allow require from packages.
  1266. #    NGetOpt is now defined in the package that requires it.
  1267. #    @ARGV and $opt_... are taken from the package that calls it.
  1268. #    Use standard (?) option prefixes: -, -- and +.
  1269.  
  1270. # 20-Sep-1990        Johan Vromans    
  1271. #    Set options w/o argument to 1.
  1272. #    Correct the dreadful semicolon/require bug.
  1273.  
  1274.  
  1275. {   package newgetopt;
  1276.     $debug = 0;            # for debugging
  1277.     $ignorecase = 1;        # ignore case when matching options
  1278. }
  1279.  
  1280. sub NGetOpt {
  1281.  
  1282.     @newgetopt'optionlist = @_;
  1283.     *newgetopt'ARGV = *ARGV;
  1284.  
  1285.     package newgetopt;
  1286.  
  1287.     local ($[) = 0;
  1288.     local ($genprefix) = "(--|-|\\+)";
  1289.     local ($argend) = "--";
  1290.     local ($error) = 0;
  1291.     local ($opt, $optx, $arg, $type, $mand, %opctl);
  1292.     local ($pkg) = (caller)[0];
  1293.  
  1294.     print STDERR "NGetOpt 1.13 -- called from $pkg\n" if $debug;
  1295.  
  1296.     # See if the first element of the optionlist contains option
  1297.     # starter characters.
  1298.     if ( $optionlist[0] =~ /^\W+$/ ) {
  1299.     $genprefix = shift (@optionlist);
  1300.     # Turn into regexp.
  1301.     $genprefix =~ s/(\W)/\\\1/g;
  1302.     $genprefix = "[" . $genprefix . "]";
  1303.     undef $argend;
  1304.     }
  1305.  
  1306.     # Verify correctness of optionlist.
  1307.     %opctl = ();
  1308.     foreach $opt ( @optionlist ) {
  1309.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  1310.     if ( $opt !~ /^(\w*)([=:][infse]@?)?$/ ) {
  1311.         print STDERR ("Error in option spec: \"", $opt, "\"\n");
  1312.         $error++;
  1313.         next;
  1314.     }
  1315.     $opctl{$1} = defined $2 ? $2 : "";
  1316.     }
  1317.  
  1318.     return 0 if $error;
  1319.  
  1320.     if ( $debug ) {
  1321.     local ($arrow, $k, $v);
  1322.     $arrow = "=> ";
  1323.     while ( ($k,$v) = each(%opctl) ) {
  1324.         print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
  1325.         $arrow = "   ";
  1326.     }
  1327.     }
  1328.  
  1329.     # Process argument list
  1330.  
  1331.     while ( $#ARGV >= 0 ) {
  1332.  
  1333.     # >>> See also the continue block <<<
  1334.  
  1335.     # Get next argument
  1336.     $opt = shift (@ARGV);
  1337.     print STDERR ("=> option \"", $opt, "\"\n") if $debug;
  1338.     $arg = undef;
  1339.  
  1340.     # Check for exhausted list.
  1341.     if ( $opt =~ /^$genprefix/ ) {
  1342.         # Double occurrence is terminator
  1343.         return ($error == 0) 
  1344.         if ($opt eq "$+$+") || ((defined $argend) && $opt eq $argend);
  1345.         $opt = $';        # option name (w/o prefix)
  1346.     }
  1347.     else {
  1348.         # Apparently not an option - push back and exit.
  1349.         unshift (@ARGV, $opt);
  1350.         return ($error == 0);
  1351.     }
  1352.  
  1353.     # Look it up.
  1354.     $opt =~ tr/A-Z/a-z/ if $ignorecase;
  1355.     unless  ( defined ( $type = $opctl{$opt} ) ) {
  1356.         print STDERR ("Unknown option: ", $opt, "\n");
  1357.         $error++;
  1358.         next;
  1359.     }
  1360.  
  1361.     # Determine argument status.
  1362.     print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
  1363.  
  1364.     # If it is an option w/o argument, we're almost finished with it.
  1365.     if ( $type eq "" ) {
  1366.         $arg = 1;        # supply explicit value
  1367.         $array = 0;
  1368.         next;
  1369.     }
  1370.  
  1371.     # Get mandatory status and type info.
  1372.     ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
  1373.  
  1374.     # Check if the argument list is exhausted.
  1375.     if ( $#ARGV < 0 ) {
  1376.  
  1377.         # Complain if this option needs an argument.
  1378.         if ( $mand eq "=" ) {
  1379.         print STDERR ("Option ", $opt, " requires an argument\n");
  1380.         $error++;
  1381.         }
  1382.         if ( $mand eq ":" ) {
  1383.         $arg = $type eq "s" ? "" : 0;
  1384.         }
  1385.         next;
  1386.     }
  1387.  
  1388.     # Get (possibly optional) argument.
  1389.     $arg = shift (@ARGV);
  1390.  
  1391.     # Check if it is a valid argument. A mandatory string takes
  1392.     # anything. 
  1393.     if ( "$mand$type" ne "=s" && $arg =~ /^$genprefix/ ) {
  1394.  
  1395.         # Check for option list terminator.
  1396.         if ( $arg eq "$+$+" || 
  1397.          ((defined $argend) && $arg eq $argend)) {
  1398.         # Push back so the outer loop will terminate.
  1399.         unshift (@ARGV, $arg);
  1400.         # Complain if an argument is required.
  1401.         if ($mand eq "=") {
  1402.             print STDERR ("Option ", $opt, " requires an argument\n");
  1403.             $error++;
  1404.             undef $arg;    # don't assign it
  1405.         }
  1406.         else {
  1407.             # Supply empty value.
  1408.             $arg = $type eq "s" ? "" : 0;
  1409.         }
  1410.         next;
  1411.         }
  1412.  
  1413.         # Maybe the optional argument is the next option?
  1414.         if ( $mand eq ":" && ($' eq "" || $' =~ /[a-zA-Z_]/) ) {
  1415.         # Yep. Push back.
  1416.         unshift (@ARGV, $arg);
  1417.         $arg = $type eq "s" ? "" : 0;
  1418.         next;
  1419.         }
  1420.     }
  1421.  
  1422.     if ( $type eq "n" || $type eq "i" ) { # numeric/integer
  1423.         if ( $arg !~ /^-?[0-9]+$/ ) {
  1424.         print STDERR ("Value \"", $arg, "\" invalid for option ",
  1425.                   $opt, " (number expected)\n");
  1426.         $error++;
  1427.         undef $arg;    # don't assign it
  1428.         }
  1429.         next;
  1430.     }
  1431.  
  1432.     if ( $type eq "f" ) { # fixed real number, int is also ok
  1433.         if ( $arg !~ /^-?[0-9.]+$/ ) {
  1434.         print STDERR ("Value \"", $arg, "\" invalid for option ",
  1435.                   $opt, " (real number expected)\n");
  1436.         $error++;
  1437.         undef $arg;    # don't assign it
  1438.         }
  1439.         next;
  1440.     }
  1441.  
  1442.     if ( $type eq "s" ) { # string
  1443.         next;
  1444.     }
  1445.  
  1446.     }
  1447.     continue {
  1448.     if ( defined $arg ) {
  1449.         if ( $array ) {
  1450.         print STDERR ('=> push (@', $pkg, '\'opt_', $opt, ", \"$arg\")\n")
  1451.             if $debug;
  1452.             eval ('push(@' . $pkg . '\'opt_' . $opt . ", \$arg);");
  1453.         }
  1454.         else {
  1455.         print STDERR ('=> $', $pkg, '\'opt_', $opt, " = \"$arg\"\n")
  1456.             if $debug;
  1457.             eval ('$' . $pkg . '\'opt_' . $opt . " = \$arg;");
  1458.         }
  1459.     }
  1460.     }
  1461.  
  1462.     return ($error == 0);
  1463. }
  1464. 1;
  1465.  
  1466.  
  1467. # Usage:
  1468. #    require "find.pl";
  1469. #
  1470. #    &find('/foo','/bar');
  1471. #
  1472. #    sub wanted { ... }
  1473. #        where wanted does whatever you want.  $dir contains the
  1474. #        current directory name, and $_ the current filename within
  1475. #        that directory.  $name contains "$dir/$_".  You are cd'ed
  1476. #        to $dir when the function is called.  The function may
  1477. #        set $prune to prune the tree.
  1478. #
  1479. # This library is primarily for find2perl, which, when fed
  1480. #
  1481. #   find2perl / -name .nfs\* -mtime +7 -exec rm -f {} \; -o -fstype nfs -prune
  1482. #
  1483. # spits out something like this
  1484. #
  1485. #    sub wanted {
  1486. #        /^\.nfs.*$/ &&
  1487. #        (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
  1488. #        int(-M _) > 7 &&
  1489. #        unlink($_)
  1490. #        ||
  1491. #        ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
  1492. #        $dev < 0 &&
  1493. #        ($prune = 1);
  1494. #    }
  1495.  
  1496. sub find {
  1497.     chop($cwd = `pwd`);
  1498.     foreach $topdir (@_) {
  1499.     (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
  1500.       || (warn("Can't stat $topdir: $!\n"), next);
  1501.     if (-d _) {
  1502.         if (chdir($topdir)) {
  1503.         ($dir,$_) = ($topdir,'.');
  1504.         $name = $topdir;
  1505.         &wanted;
  1506.         $topdir =~ s,/$,, ;
  1507.         &finddir($topdir,$topnlink);
  1508.         }
  1509.         else {
  1510.         warn "Can't cd to $topdir: $!\n";
  1511.         }
  1512.     }
  1513.     else {
  1514.         unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
  1515.         ($dir,$_) = ('.', $topdir);
  1516.         }
  1517.         $name = $topdir;
  1518.         chdir $dir && &wanted;
  1519.     }
  1520.     chdir $cwd;
  1521.     }
  1522. }
  1523.  
  1524. sub finddir {
  1525.     local($dir,$nlink) = @_;
  1526.     local($dev,$ino,$mode,$subcount);
  1527.     local($name);
  1528.  
  1529.     # Get the list of files in the current directory.
  1530.  
  1531.     opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return);
  1532.     local(@filenames) = readdir(DIR);
  1533.     closedir(DIR);
  1534.  
  1535.     if ($nlink == 2) {        # This dir has no subdirectories.
  1536.     for (@filenames) {
  1537.         next if $_ eq '.';
  1538.         next if $_ eq '..';
  1539.         $name = "$dir/$_";
  1540.         $nlink = 0;
  1541.         &wanted;
  1542.     }
  1543.     }
  1544.     else {                    # This dir has subdirectories.
  1545.     $subcount = $nlink - 2;
  1546.     for (@filenames) {
  1547.         next if $_ eq '.';
  1548.         next if $_ eq '..';
  1549.         $nlink = $prune = 0;
  1550.         $name = "$dir/$_";
  1551.         &wanted;
  1552.         if ($subcount > 0) {    # Seen all the subdirs?
  1553.  
  1554.         # Get link count and check for directoriness.
  1555.  
  1556.         ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
  1557.         
  1558.         if (-d _) {
  1559.  
  1560.             # It really is a directory, so do it recursively.
  1561.  
  1562.             if (!$prune && chdir $_) {
  1563.             &finddir($name,$nlink);
  1564.             chdir '..';
  1565.             }
  1566.             --$subcount;
  1567.         }
  1568.         }
  1569.     }
  1570.     }
  1571. }
  1572. 1;
  1573.  
  1574. __END__
  1575. upper-case
  1576.     DISABLE
  1577.     tag <$argv[0]> is not in upper case.
  1578. lower-case
  1579.     DISABLE
  1580.     tag <$argv[0]> is not in lower case.
  1581. mixed-case
  1582.     ENABLE
  1583.     tag case is ignored
  1584. here-anchor
  1585.     ENABLE
  1586.     bad form to use `here' as an anchor!
  1587. require-head
  1588.     ENABLE
  1589.     no <TITLE> in HEAD element.
  1590. once-only
  1591.     ENABLE
  1592.     tag <$argv[0]> should only appear once.  I saw one on line $argv[1]!
  1593. body-no-head
  1594.     ENABLE
  1595.     <BODY> but no <HEAD>.
  1596. html-outer
  1597.     ENABLE
  1598.     outer tags should be <HTML> .. </HTML>.
  1599. head-element
  1600.     ENABLE
  1601.     <$argv[0]> can only appear in the HEAD element.
  1602. non-head-element
  1603.     ENABLE
  1604.     <$argv[0]> cannot appear in the HEAD element.
  1605. obsolete
  1606.     ENABLE
  1607.     <$argv[0]> is obsolete.
  1608. mis-match
  1609.     ENABLE
  1610.     unmatched </$argv[0]> (no matching <$argv[0]> seen).
  1611. img-alt
  1612.     ENABLE
  1613.     IMG does not have ALT text defined.
  1614. nested-element
  1615.     ENABLE
  1616.     <$argv[0]> cannot be nested -- </$argv[0]> not yet seen for <$argv[0]> on line $argv[1].
  1617. mailto-link
  1618.     DISABLE
  1619.     did not see <LINK REV=MADE HREF="mailto..."> in HEAD.
  1620. element-overlap
  1621.     ENABLE
  1622.     </$argv[0]> on line $argv[1] seems to overlap <$argv[2]>, opened on line $argv[3].
  1623. unclosed-element
  1624.     ENABLE
  1625.     no closing </$argv[0]> seen for <$argv[0]> on line $argv[1].
  1626. markup-in-comment
  1627.     ENABLE
  1628.     markup embedded in a comment can confuse some browsers.
  1629. unknown-attribute
  1630.     ENABLE
  1631.     unknown attribute "$argv[1]" for element <$argv[0]>.
  1632. leading-whitespace
  1633.     ENABLE
  1634.     should not have whitespace between "<" and "$argv[0]>".
  1635. required-attribute
  1636.     ENABLE
  1637.     the $argv[0] attribute is required for the <$argv[1]> element.
  1638. unknown-element
  1639.     ENABLE
  1640.     unknown element <$argv[0]>.
  1641. odd-quotes
  1642.     ENABLE
  1643.     odd number of quotes in element <$argv[0]>.
  1644. heading-order
  1645.     ENABLE
  1646.     bad style - heading <$argv[0]> follows <H$argv[1]> on line $argv[2].
  1647. bad-link
  1648.     DISABLE
  1649.     target for anchor "$argv[0]" not found.
  1650. expected-attribute
  1651.     ENABLE
  1652.     expected an attribute for <$argv[0]>.
  1653. unexpected-open
  1654.     ENABLE
  1655.     unexpected < in <$argv[0]> -- potentially unclosed element.
  1656. required-context
  1657.     ENABLE
  1658.     illegal context for <$argv[0]> - must appear in <$argv[1]> element.
  1659. unclosed-comment
  1660.     ENABLE
  1661.     unclosed comment (comment should be: <!-- ... -->).
  1662. illegal-closing
  1663.     ENABLE
  1664.     element <$argv[0]> is not a container -- </$argv[0]> not legal.
  1665. netscape-markup
  1666.     ENABLE
  1667.     <$argv[0]> is netscape specific (use "-x netscape" to allow this).
  1668. netscape-attribute
  1669.     ENABLE
  1670.     attribute `$argv[0]' for <$argv[1]> is netscape specific (use "-x netscape" to allow this).
  1671. physical-font
  1672.     DISABLE
  1673.     <$argv[0]> is physical font markup -- use logical (such as $argv[1]).
  1674. repeated-attribute
  1675.     ENABLE
  1676.     attribute $argv[0] is repeated in element <$argv[1]>
  1677. must-follow
  1678.     ENABLE
  1679.     <$argv[0]> must immediately follow <$argv[1]>
  1680. empty-container
  1681.     ENABLE
  1682.     empty container element <$argv[0]>.
  1683. directory-index
  1684.     ENABLE
  1685.     directory $argv[0] does not have an index file ($argv[1])
  1686. closing-attribute
  1687.     ENABLE
  1688.     closing tag <$argv[0]> should not have any attributes specified.
  1689. attribute-delimiter
  1690.     ENABLE
  1691.     use of ' for attribute value delimiter is not supported by all browsers (attribute $argv[0] of tag $argv[1])
  1692.  
  1693.