home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / fteo46b5.zip / fteo46b5 / scripts / mkcontents.pl < prev   
Perl Script  |  1998-01-31  |  4KB  |  184 lines
  1. #!/usr/bin/perl -w
  2. # mkcontents
  3.  
  4. #use strict qw(refs subs);
  5.  
  6. sub openlevel;
  7. sub closelevel;
  8. sub newindex;
  9. sub doneindex;
  10. sub html;
  11. sub tag;
  12. sub out;
  13.  
  14. $output_level = 0;
  15. $output = 0;
  16.  
  17. # read input files
  18. open(INDEX, "<INDEX") || die "open INDEX: $!";
  19. while (defined($filename = <INDEX>)) {
  20.     chomp $filename;
  21.     open(FILE, "<$filename") || die "open $filename: $!";
  22.     {
  23.         local $/ = undef;
  24.         $filetext = <FILE>;
  25.         print STDERR "$filename:\n";
  26.         $output = 0;
  27.         html($filetext);
  28.     }
  29.     close(FILE);
  30. }
  31. close(INDEX);
  32. closelevel(0);
  33.  
  34. sub html {
  35.     my $text = $_[0];
  36.     my $cpos = 0;
  37.  
  38.     TAG: while ($opos = $cpos, ($cpos = index($text, "<", $cpos) + 1) != 0) {
  39.         pos($text) = $cpos;  # match regexp there
  40.  
  41.         out(substr($text, $opos, pos($text) - $opos - 1));
  42.         # output text
  43.  
  44.         $TAG = undef;
  45.         
  46.         if ($text =~ /\G!(.*?)(--.*?--\s*)*(.*?)>/sgo) { # comment
  47.             $cpos = pos $text;
  48.             #&comment($2);
  49.             next TAG;
  50.         }
  51.         
  52.         pos ($text) = $cpos;
  53.         if ($text =~ /\G\s*([\/]?[A-Za-z0-9]*)/go) {
  54.             $cpos = pos($text);
  55.             $TAG = uc $1;
  56.             
  57.             #print "<|", $TAG, "\n";
  58.         }
  59.         
  60.         undef %ARGS;
  61.         
  62.         ARG: while (1) {
  63.             pos($text) = $cpos;
  64.             
  65.             if ($text =~ /\G\s*/go) { $cpos = pos ($text); } # skip whitespace
  66.             
  67.             last ARG unless $text =~ /\G([A-Za-z0-9]+)\s*/go; # param name
  68.             $cpos = pos $text;
  69.             
  70.             $pname = uc $1;
  71.             if ($text =~ /\G=\s*/go) {
  72.                 $cpos = pos $text;
  73.                 
  74.                 if ($text =~ /\G"([^"]*)"\s*/go) {
  75.                     $cpos = pos $text;
  76.                     #print "+|$pname=\"$1\"\n";
  77.                     $ARGS{$pname} = $1;
  78.                     next ARG;
  79.                 };
  80.                 pos($text) = $cpos;
  81.                 if ($text =~ /\G'([^']*)'\s*/go) {
  82.                     $cpos = pos $text;
  83.                     #print "+|$pname='$1'\n";
  84.                     $ARGS{$pname} = $1;
  85.                     next ARG;
  86.                 };
  87.                 pos($text) = $cpos;
  88.                 if ($text =~ /\G([^ <>"']+)\s*/go) {
  89.                     $cpos = pos $text;
  90.                     #print "+|$pname=$1\n";
  91.                     $ARGS{$pname} = $1;
  92.                     next ARG;
  93.                 };
  94.                 $ARGS{$pname} = "";
  95.                 die "no value for tag";
  96.             }
  97.             #print "+|$pname\n";
  98.         }
  99.         pos($text) = $cpos;
  100.         ($cpos = index($text, ">", $cpos) + 1) != 0 or die "tag without end";
  101.         
  102.         tag($TAG, \%ARGS);
  103.     }
  104.     out(substr($text, $opos, length($text) - $opos));
  105. }
  106.  
  107. sub closelevel {
  108.     my $level = $_[0];
  109.     
  110.     while ($output_level > $level) {
  111.         print "\n</DL>\n";
  112.         $output_level--;
  113.     }
  114. }
  115.  
  116. sub openlevel {
  117.     my $level = $_[0];
  118.  
  119.     while ($output_level < $level) {
  120.         print "<DL>\n";
  121.         $output_level++;
  122.     }
  123. }
  124.  
  125. sub newindex {
  126.     my $level = $_[0];
  127.  
  128.     closelevel($level);
  129.     openlevel($level);
  130.     print "\n<LI>";
  131.     $output = 1;
  132. }
  133.  
  134. sub doneindex {
  135.     my $level = $_[0];
  136.  
  137.     warn "$filename:level:$level mismatch" if ($output_level != $level);
  138.     print "</LI>\n";
  139.     $output = 0;
  140. }
  141.  
  142. sub tag {
  143.     my $TAG = $_[0];
  144.     my %ARGS = %{$_[1]};
  145.  
  146.     $TAG eq 'TITLE' && do {
  147.         newindex(1);
  148.         print "<A HREF=\"$filename\" TARGET=\"main\">\n";
  149.     }
  150.     or $TAG eq "/TITLE" && do {
  151.         print "</A>";
  152.         doneindex(1);
  153.     }
  154.     or $TAG =~ /^H([1-6])$/o && do {
  155.         newindex(1 + $1);
  156.     }
  157.     or $TAG =~ /^\/H([1-6])$/o && do {
  158.         doneindex(1 + $1);
  159.     }
  160.     or $TAG eq 'A' && do {
  161.         if (defined $ARGS{"NAME"}) {
  162.             $aname = $filename . '#' . $ARGS{"NAME"};
  163.             print "<A HREF=\"$aname\" TARGET=\"main\">" if $output;
  164.         } 
  165.     }
  166.     or $TAG eq '/A' && do {
  167.         print "</A>" if $output;
  168.     }
  169. }
  170.  
  171. sub out {
  172.     my $lin = $_[0];
  173.     my $first = 1;
  174.     my $i;
  175.  
  176.     print $lin if $output;
  177. }
  178.  
  179. sub comment {
  180. }
  181.  
  182. sub badtag {
  183. }
  184.