home *** CD-ROM | disk | FTP | other *** search
/ HTML - Publishing on the Internet / html_cdrom.iso / tools / html / mac / check / htmlsrpl.pl < prev    next >
Encoding:
Perl Script  |  1995-02-18  |  10.7 KB  |  259 lines
  1. #!/usr/local/bin/perl
  2. #htmlsrpl.pl: HTML-aware search-and-replace; acts either only outside HTML/SGML
  3. #             tags, or only within HTML/SGML tags; can also upper-case tag names
  4. #
  5. # Typical use:
  6. #
  7. #   perl htmlsrpl.pl [options] infile.html > outfile.html
  8. #
  9. # Where options have the form "option=value"; all options should precede
  10. # filename arguments on the command line.  (See the documentation.)
  11. #
  12. # Copyright H. Churchyard 1994, 1995 -- freely redistributable.  This code is
  13. # awk-influenced (so sue me).  Tested under Perl 4 (I'm still not sure whether
  14. # the fact that "s/$x/$y/" is equivalent to "s/$x/$y/e" is a bug or not).
  15. #
  16. #  Version 1.0 12/21/94 -- Preliminary version.
  17. #  Version 1.01 12/22/94 -- Minor bugfix.
  18. #  Version 1.1 1/7/95 -- Added inside=, inmost=, oustside= , etc.  Included in
  19. # htmlchek 4.0 release.
  20. #  Version 1.11 1/22/95 -- Added "Changed!/Unchanged" final status messages.
  21. # Included in htmlchek 4.1 release.
  22. #
  23. eval "exec /usr/local/bin/perl -S $0 $*"
  24.     if $running_under_some_shell; # this emulates #! processing on NIH machines.
  25. #process any FOO=bar switches
  26. $old= ''; $new = ''; $intags = 0; $regexp = 0; $regeval = 0; $upcase = 0;
  27. $lines = 0; $delete = 0; $case = 0; $slash=0; $inmost=''; $inside = '';
  28. $outside = '';
  29. eval '$'.$1.'$2;' while $ARGV[0] =~ /^(old=|new=|intags=|lines=|regexp=|regeval=|upcase=|delete=|case=|slash=|inmost=|inside=|outside=)(.*)/ && shift;
  30. $[ = 1;                 # set array base to 1
  31. $, = ' ';               # set output field separator
  32. $\ = "\n";              # set output record separator
  33. foreach $X (@ARGV) {
  34.     if ($X =~ /^[^=]+=/) {
  35.         print STDERR "Apparent misspelled or badly-placed command-line option $&";
  36.         print STDERR "Attempting to continue anyway...";}}
  37. $filstr = join(' ',@ARGV); $changed = 0;
  38. if ($lines)  {$/ = "\0777"; $* = 1;}
  39. else {$/ = "\n";}
  40. if (($outside) && (!(($inside) || ($inmost)))) {$applyit = 1;}
  41. else {$applyit = 0;}
  42. #
  43. $unpair{'!--'} = 1; $unpair{'!DOCTYPE'} = 1; $unpair{'BASE'} = 1;
  44. $unpair{'BR'} = 1; $unpair{'COMMENT'} = 1; $unpair{'HR'} = 1;
  45. $unpair{'IMG'} = 1; $unpair{'INPUT'} = 1; $unpair{'ISINDEX'} = 1;
  46. $unpair{'LINK'} = 1; $unpair{'META'} = 1; $unpair{'NEXTID'} = 1;
  47. $unpair{'ATOP'} = 1; $unpair{'LEFT'} = 1;
  48. $unpair{'OVER'} = 1; $unpair{'OVERLAY'} = 1; $unpair{'RIGHT'} = 1;
  49. $unpair{'TAB'} = 1; $unpair{'BASEFONT'} = 1; $unpair{'WBR'} = 1;
  50. $nestvar = 0; $numins = 0; $numout = 0;
  51. if ($inmost) {
  52.     $inmost =~ tr/a-z/A-Z/;
  53.     if ($inmost =~ /[^-.a-zA-Z0-9]/) {
  54.         die 'Non-alphanumeric value of inmost= was specified';}
  55.     if (defined $unpair{$inmost}) {
  56.         die "Non-pairing tag $inmost specified as value of inmost=";}}
  57. if ($inside) {
  58.    $numins = (@inarr = split(/,/, $inside));
  59.         for ($i = 1; $i <= $numins; ++$i) {
  60.             $inarr[$i] =~ tr/a-z/A-Z/;
  61.             if ((!$inarr[$i]) || ($inarr[$i] =~ /[^-.a-zA-Z0-9]/)) {
  62.                die 'Non-alphanumeric value of inside= was specified';}
  63.             if (defined $xxin{$inarr[$i]}) {
  64.                die 'Duplicate values of inside= were specified';}
  65.             if (defined $unpair{$inarr[$i]}) {
  66.                die "Non-pairing tag $inarr[$i] specified as value of inside=";}
  67.             else {
  68.                $xxin{$inarr[$i]} = 1;}}}
  69. if ($outside) {
  70.    $numout = (@outarr = split(/,/, $outside));
  71.         for ($i = 1; $i <= $numout; ++$i) {
  72.             $outarr[$i] =~ tr/a-z/A-Z/;
  73.             if ((!$outarr[$i]) || ($outarr[$i] =~ /[^-.a-zA-Z0-9]/)) {
  74.                die 'Non-alphanumeric value of outside= was specified';}
  75.             if (defined $xxout{$outarr[$i]}) {
  76.                die 'Duplicate values of outside= were specified';}
  77.             if (defined $xxin{$outarr[$i]}) {
  78.                die "Tagname $outarr[$i] specified as both outside= and inside=";}
  79.             if (defined $unpair{$outarr[$i]}) {
  80.                die "Non-pairing tag $outarr[$i] specified as value of outside=";}
  81.             else {
  82.                $xxout{$outarr[$i]} = 1;}}}
  83. #
  84. if ((!$old) && (!$upcase)) {die "No `old=' string was specified";}
  85. if (($delete) && (($new) || ($regexp) || ($regeval))) {
  86.      die "Incompatible option specified with `delete=1'";}
  87. if (($regexp) && ($regeval)) {die 'Both regexp=1 and regeval=1 specified';}
  88. if (($case) && (!$delete) && (!$regexp) && (!$regeval)) {
  89.      die 'Option case=1 specified without any of regexp=1, regeval=1, or delete=1 also being specified';}
  90. if ($delete) {$slash=1;}
  91. if (($upcase) || ($delete) || ($slash)) {$intags = 1;}
  92. #
  93. # Main
  94. #
  95. # Variable ``$state'' is one if there is an unresolved `<', zero otherwise.
  96. #  ``$lastbeg'' is zero if no `<' has ocurred in $_, otherwise it points to the
  97. # character immediately after the last `<' encountered.
  98. #
  99. $xRS = "\n"; $state = 0;
  100. while (<>) {
  101.     if ($_ =~ /$xRS$/o) { # strip record separator, allow for last line to
  102.         chop;}            # be unterminated.
  103.     $lastbeg = 0; $currsrch = 1; $txtbeg = 1;
  104.     while ((((substr($_, $currsrch) =~ /[<>]/) eq 1) &&
  105.       ($RSTART = length($`)+1)) != 0) {
  106.         $currsrch = ($currsrch + $RSTART);
  107.         if (substr($_, ($currsrch - 1), 1) eq '<') {
  108.             if ($state) {
  109.                 print "\nERROR!";
  110.                 die "Multiple `<' without `>' ERROR!";}
  111.             else {
  112.                 if (($currsrch > length($_)) ||
  113.                   (substr($_, $currsrch, 1) =~ /^[ \t]$/)) {
  114.                     print "\nERROR!";
  115.                     die "Whitespace after `<': Bad SGML syntax ERROR!";}
  116.                 else {
  117.                     if ($currsrch > ($txtbeg + 1)) {
  118.                         if ((!$intags) && (($applyit) || (!(($inmost) ||
  119.                           ($numins) || ($numout))))) {
  120.                             printf "%s", &changeht(substr($_, $txtbeg,
  121.                               ($currsrch - ($txtbeg + 1))));}
  122.                         else {
  123.                             printf "%s", substr($_, $txtbeg,
  124.                               ($currsrch - ($txtbeg + 1)));}}
  125.                 $deletit = 0;
  126.                 $lastbeg = $currsrch; $state = 1;}}}
  127.         else {
  128.             if (substr($_, ($currsrch - 1), 1) eq '>') {
  129.                 if ($state == 0) {
  130.                     next;}        #`>' without `<'
  131.                 else {
  132.                     &parsetag($currsrch - 1);
  133.                     if (!$deletit) {printf "%s", '>';}
  134.                     $txtbeg = $currsrch; $state = 0;}}
  135.             else {die 'Internal error, ignore';}}}
  136. #At EOL:
  137.     if ($state == 1) {
  138.         &parsetag(length($_) + 1);}
  139.     elsif ($txtbeg <= length($_)) {
  140.         if ((!$intags) && (($applyit) || (!(($inmost) || ($numins) ||
  141.           ($numout))))) {
  142.             printf "%s", &changeht(substr($_, $txtbeg));}
  143.         else {printf "%s", substr($_, $txtbeg);}}
  144.     if (!(($state) && ($deletit))) {printf "\n";}}
  145. #
  146. #END routine:
  147. #
  148. if ($state) {
  149.     die "Was awaiting a `>' ERROR! at END";}
  150. if ($changed) {
  151.     print STDERR "Changed! on input", $filstr;}
  152. else {
  153.     print STDERR "Unchanged on input", $filstr;}
  154. #
  155. #
  156. sub parsetag {
  157.     local($inp) = @_;
  158.     $docap = $lastbeg;
  159.     if (!$lastbeg) {
  160.         $strx = '' ; $lastbeg = 1;}
  161.     else {$strx= '<';}
  162.     if ($inp != $lastbeg) {
  163.         $str = &upc(substr($_, $lastbeg, ($inp - $lastbeg)));
  164.         if (($oldapply) || (!(($inmost) || ($numins) ||($numout)))) {
  165.             if (($slash) && ($docap) && ($str =~ /^\//))
  166.                 {$strx = ($strx . '/'); $str= substr($str, 2);}
  167.             if ($delete) {
  168.                 if ($docap) {&getdel($str);}
  169.                 if (!$deletit) {printf "%s%s", $strx, $str;}
  170.                 else {$changed=1;}}
  171.             else {
  172.                 if (($intags) && ($old))
  173.                   {printf "%s%s", $strx, &changeht($str);}
  174.                 else {printf "%s%s", $strx, $str;}}}
  175.         else {printf "%s%s", $strx, $str;}}}
  176. #
  177. sub upc {
  178.     local($upcx) = @_;
  179.     if ($docap) {
  180.         $upcx =~ /^[^ \t\n]+/;
  181.         ($tagname = $&) =~ tr/a-z/A-Z/;
  182.         if ($upcase) {$upcx = ($tagname . $');}
  183.         $oldapply = $applyit;
  184.         #tag stack accounting
  185.         if ((($inmost) || ($numins)|| ($numout)) &&
  186.           (!(defined $unpair{$tagname}))) {
  187.             $applyit = 1; $clostag = '';
  188.             if ($tagname !~ /^\//) {
  189.                 ++$nestvar;
  190.                 $nestarr[$nestvar] = $tagname;}
  191.             else {
  192.                 $clostag = substr($tagname,2);
  193.                 while ($nestarr[$nestvar] ne $clostag) {
  194.                     --$nestvar;
  195.                     if ($nestvar <= 0) {
  196.                         print "\nERROR!";
  197.                         die "/$clostag tag encountered when apparently not in $clostag element";}}
  198.                 --$nestvar;}
  199.             if (($inmost) && ($nestarr[$nestvar] ne $inmost)) {
  200.                 $applyit = 0;}
  201.             if ($numins) {
  202.                 if ($nestvar < $numins)  {$applyit = 0;}
  203.                 else {
  204.                     $mask = 1;
  205.                     $stackstr = (" " . join(" ",@nestarr[1..$nestvar]) . " ");
  206.                     foreach $X (keys %xxin) {
  207.                         if (index($stackstr,(" " . $X . " ")) <= 0) {
  208.                             $mask = 0;}}
  209.                     if (($applyit) && ($mask)) {$applyit = 1;}
  210.                     else {$applyit = 0;}}}
  211.             if (($numout) && ($nestvar)) {
  212.                 $mask = 1;
  213.                 $stackstr = (" " . join(" ",@nestarr[1..$nestvar]) . " ");
  214.                 foreach $X (keys %xxout) {
  215.                 ##print $stackstr,"XX",(" " . $X . " ");##debugXX
  216.                     if (index($stackstr,(" " . $X . " ")) > 0) {
  217.                         $mask = 0;}}
  218.                 if (($applyit) && ($mask)) {$applyit = 1;}
  219.                 else {$applyit = 0;}}
  220.              if ($clostag) {$oldapply = $applyit;}}}
  221.     return $upcx;}
  222. #
  223. sub getdel {
  224.     local($inz) = @_;
  225.     $inz =~ /^[^ \t\n]+/;
  226.     $X = $&;
  227.     if ($case) {
  228.         if ($X =~ /$old/io) {
  229.             $deletit = 1;}}
  230.     else {
  231.         if ($X =~ /$old/o) {
  232.             $deletit = 1;}}}
  233. #
  234. sub changeht {
  235.     local($field) = @_;
  236.     if ($regeval) {
  237.         if ($case) {
  238.             $X = ($field =~ s/$old/$new/eeigo);}
  239.         else {
  240.             $X = ($field =~ s/$old/$new/eego);}
  241.         if ($X) {$changed = 1;}
  242.         return $field;}
  243.     elsif ($regexp) {
  244.         if ($case) {
  245.             $X = ($field =~ s/$old/$new/igo);}
  246.         else {
  247.             $X = ($field =~ s/$old/$new/go);}
  248.         if ($X) {$changed = 1;}
  249.         return $field;}
  250.     else {
  251.         $startf = 1; $newf = '';
  252.         while (($ndx = index(substr($field,$startf),$old)) > 0) {
  253.             $changed = 1;
  254.             $newf = ($newf . substr($field,$startf,($ndx-1)) . $new);
  255.             $startf = ($startf + ($ndx-1) + length($old));}
  256.         $newf = ($newf . substr($field,$startf));
  257.         return $newf;}}
  258. ##EOF
  259.