home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / fte0827.zip / doc / html2ipf.pl < prev    next >
Perl Script  |  1996-10-27  |  10KB  |  315 lines
  1. #!perl5 -w
  2.  
  3. # html2ipf - version 0.4
  4. # by Marko Macek, mark@hermes.si | marko.macek@snet.fer.uni-lj.si
  5. # needs some work, but is much faster than 0.2.
  6.  
  7. # version 0.4: handle some internal A HREF and A NAME.
  8.  
  9. $h2i = 'html2ipf';
  10. $h2i_version = '0.4';
  11.  
  12. print ".*! $h2i $h2i_version\n\n";
  13.  
  14. $dl_param = 'compact tsize=10 break=all';
  15. $ol_param = 'compact';
  16. $ul_param = 'compact';
  17. $lmargin  = ':lm margin=1.';
  18. $fontspec = ''; #:font facename=Helv size=16x8.';
  19.  
  20. undef $/; # slurp whole file as one line
  21. $line = <>; # read input file
  22.  
  23. $wasws = 0;
  24.  
  25. for ($pass = 1; $pass <= 2; $pass++) {
  26.     $nheads = 0;
  27.     $list_level = 0;
  28.     $head_level = 0;
  29.     $pre = 0;
  30.     $in_head = 0;
  31.     $ahref = 0;
  32.     $naname = 0;
  33.  
  34.     $cpos = 0;
  35.     
  36.     TAG: 
  37.     while ($opos = $cpos,
  38.            ($cpos = index($line, "<", $cpos) + 1) != 0) # skip to next tag
  39.     {
  40.         pos($line) = $cpos;  # match regexp there
  41.         
  42.         &out(substr($line, $opos, pos($line) - $opos - 1)); # output text
  43.         
  44.         $TAG = undef;
  45.         
  46.         if ($line =~ /\G!(.*?)(--.*?--\s*)*(.*?)>/sgo) { # comment
  47.             $cpos = pos $line;
  48.             #&comment($2);
  49.             next TAG;
  50.         }
  51.         
  52.         pos ($line) = $cpos;
  53.         if ($line =~ /\G\s*([\/]?[A-Za-z0-9]*)/go) {
  54.             $cpos = pos($line);
  55.             $TAG = uc $1;
  56.             
  57.             #print "<|", $TAG, "\n";
  58.         }
  59.         
  60.         undef %ARGS;
  61.         
  62.         ARG:
  63.         while (1) {
  64.             pos($line) = $cpos;
  65.             
  66.             if ($line =~ /\G\s*/go) { $cpos = pos ($line); } # skip whitespace
  67.             
  68.             last ARG unless $line =~ /\G([A-Za-z0-9]+)\s*/go; # param name
  69.             $cpos = pos $line;
  70.             
  71.             $pname = uc $1;
  72.             if ($line =~ /\G=\s*/go) {
  73.                 $cpos = pos $line;
  74.                 
  75.                 if ($line =~ /\G"([^"]*)"\s*/go) {
  76.                     $cpos = pos $line;
  77.                     #print "+|$pname=\"$1\"\n";
  78.                     $ARGS{$pname} = $1;
  79.                     next ARG;
  80.                 };
  81.                 pos($line) = $cpos;
  82.                 if ($line =~ /\G'([^']*)'\s*/go) {
  83.                     $cpos = pos $line;
  84.                     #print "+|$pname='$1'\n";
  85.                     $ARGS{$pname} = $1;
  86.                     next ARG;
  87.                 };
  88.                 pos($line) = $cpos;
  89.                 if ($line =~ /\G([^ <>"']+)\s*/go) {
  90.                     $cpos = pos $line;
  91.                     #print "+|$pname=$1\n";
  92.                     $ARGS{$pname} = $1;
  93.                     next ARG;
  94.                 };
  95.                 $ARGS{$pname} = "";
  96.                 die "no value for tag";
  97.             }
  98.             #print "+|$pname\n";
  99.         }
  100.         pos($line) = $cpos;
  101.         ($cpos = index($line, ">", $cpos) + 1) != 0 or die "tag without end";
  102.         
  103.         &tag($TAG, \%ARGS);
  104.     }
  105.     
  106.     &out(substr($line, $opos, length($line) - $opos));
  107.     print STDERR "\n";
  108. }
  109.  
  110. sub put {
  111.     my $lin = $_[0];
  112.  
  113.     print $lin;
  114.  
  115.     $wasws = ($lin =~ /[\n\t ]$/os);
  116. }
  117.  
  118. sub tag {
  119.     my $TAG = $_[0];
  120.     my %ARGS = %{$_[1]};
  121.  
  122.     if ($pass == 1) { # during first pass, check for: A NAME=...
  123.         $TAG =~ /^\/H[1-6]$/o  && do {
  124.             $nheads++;
  125.             print STDERR ".";
  126.         }
  127.         or $TAG eq 'A' && do {
  128.             $naname++;
  129.             print STDERR %ARGS if $naname > 1;
  130.             if (defined $ARGS{"NAME"}) {
  131.                 $aname = '#' . $ARGS{"NAME"};
  132.             } 
  133.         }
  134.         or $TAG eq '/A' && do {
  135.             $naname--;
  136.             if ($naname == 0) {
  137.                 $rnames{$aname} = $nheads - 1;
  138.             }
  139.         }
  140.     } elsif ($pass == 2) {
  141.         $list_level = ($list_level < 0) ? 0 : $list_level;
  142.         
  143.         $TAG eq 'B'       && do { put(':hp2.') unless $in_head; }
  144.         or $TAG eq '/B'      && do { put(':ehp2.') unless $in_head; }
  145.         or $TAG eq 'STRONG'  && do { put(':hp7.')  unless $in_head; }
  146.         or $TAG eq '/STRONG' && do { put(':ehp7.') unless $in_head; }
  147.         or $TAG eq 'I'       && do { put(':hp1.')  unless $in_head; }
  148.         or $TAG eq '/I'      && do { put(':ehp1.') unless $in_head; }
  149.         or $TAG eq 'TT'      && do { put(':hp2.')  unless $in_head; }
  150.         or $TAG eq '/TT'     && do { put(':ehp2.') unless $in_head; }
  151.         or $TAG eq 'BR'      && do { put("\n.br\n"); $wasws = 1; }
  152.         or $TAG eq 'HR'      && do { put("\n.br\n"); $wasws = 1; }
  153.         or $TAG eq 'P'       && do { put("\n:p."); $wasws = 1; }
  154.         or $TAG eq 'LI'      && do { put("\n:li."); $wasws = 1;} 
  155.         or $TAG eq 'CENTER'  && do { put(':lines align=center.'); }
  156.         or $TAG eq '/CENTER' && do { put(':elines.'); $wasws = 1; }
  157.         or $TAG eq 'DL'      && do { put(":dl " . $dl_param . '.'); $list_level++; } 
  158.         or $TAG eq '/DL'     && do { put(':edl.'); $list_level--; $wasws = 1; }
  159.         or $TAG eq 'DD'      && do { put("\n:dd."); $wasws = 1; }
  160.         or $TAG eq 'DT'      && do { put("\n:dt."); $wasws = 1; }
  161.         or $TAG eq 'PRE'     && do { put(':xmp.'); $pre++; }
  162.         or $TAG eq '/PRE'    && do { put(':exmp.'); $pre--; $wasws = 1; }
  163.         or $TAG eq 'XMP'     && do { put(':xmp.'); $pre++; }
  164.         or $TAG eq '/XMP'    && do { put(':exmp.'); $pre--; $wasws = 1; }
  165.         or $TAG eq 'OL>'     && do { put(":ol " . $ol_param . '.'); $list_level++; }
  166.         or $TAG eq '/OL'     && do { put(":eol."); $list_level--; $wasws = 1; }
  167.         or $TAG eq 'UL'      && do { put(":ul " . $ul_param . '.'); $list_level++; }
  168.         or $TAG eq '/UL'     && do { put(":eul."); $list_level--; $wasws = 1; }
  169.         or $TAG eq 'IMG'     && do {
  170.             $pic = $ARGS{"SRC"};
  171.             $pic =~ s/gif$/bmp/i;
  172.             put(":artwork runin name='$pic'.") unless $in_head;
  173.         }
  174.         or $TAG eq 'HTML'    && do { put("\n:userdoc.\n") }
  175.         or $TAG eq '/HTML'   && do { put("\n:euserdoc.\n") }
  176.         or $TAG eq 'TITLE'   && do { put("\n:title.") }
  177.         or $TAG eq '/TITLE'  && do { put("\n") }
  178.         or $TAG eq '/A' && do { 
  179.             if ($ahref > 0) {
  180.                 put(":elink.");
  181.                 --$ahref;
  182.             }
  183.         }
  184.         or $TAG eq 'A' && do {
  185.             if (defined $ARGS{"HREF"}) {
  186.                 if ($ARGS{"HREF"} =~ /^#/) {
  187.                     if (defined $rnames{$ARGS{"HREF"}}) {
  188.                         $id = $rnames{$ARGS{"HREF"}};
  189.                         put(":link reftype=hd refid=$id.");
  190.                         ++$ahref;
  191.                     } else {
  192.                         print STDERR "no link for " . $ARGS{"HREF"} . "\n";
  193.                     }
  194.                 } else {
  195.                     print STDERR "external ref not handled: " . $ARGS{"HREF"} . "\n";
  196.                 }
  197.             }
  198.         }
  199.         or $TAG =~ /^\/H[1-6]$/o  && do {
  200.             $nheads++;
  201.             put("\n" . $fontspec . $lmargin . ":i1." . $curhead . "\n:p.");
  202.             $in_head = 0;
  203.             $wasws = 1;
  204.             print STDERR ".";
  205.         }
  206.         or $TAG =~ /^H([1-6])/o   && do {
  207.             $hl = $1;
  208.             if ($hl > $head_level + 1) { # hack for bad headings
  209.                 $hl = $head_level + 1;
  210.             }
  211.             $head_level = $hl;
  212.             put("\n:h$hl id=$nheads.");
  213.             $in_head = 1;
  214.             $curhead = "";
  215.         }
  216.     }
  217. }
  218.  
  219. sub out {
  220.     my $lin = $_[0];
  221.     my $first = 1;
  222.     my $i;
  223.  
  224.     return if ($pass == 1);
  225.  
  226.     #$lin =~ s/\<\;/\</og;
  227.     #$lin =~ s/\>\;/\>/og;
  228.     #$lin =~ s/\&\;/\&/og;
  229.     ##$lin =~ s/\n/ /og;
  230.     #print $lin;
  231.  
  232.     #    $lin =~ s/\./\&per\./og;             # .
  233.     $lin =~ s/\<\;/\</og;            # <
  234.     $lin =~ s/\>\;/\>/og;            # >
  235.     $lin =~ s/\:/\&colon\./og;         # :
  236.     $lin =~ s/\&\;/\&\./og;      # &
  237.  
  238.     if ($pre > 0) {
  239.         print $lin; 
  240.     } else {
  241. #        $lin =~ s/\n / /osg;
  242.         $lin =~ s/\n/ /osg;
  243.         $lin =~ s/ +/ /og;
  244.         if ($wasws) {
  245.             $lin =~ s/^ +//o;
  246.         }
  247.         if ($in_head) {
  248.             $curhead .= $lin;
  249.         }
  250.         
  251.         while ($lin ne "") {
  252.             put("\n") unless ($first);
  253.             put(" ") if $line =~ /^\./;
  254.             if (length($lin) <= 70) {
  255.                 put($lin);
  256.                 $lin = "";
  257.             } else {
  258.                 $i = 70;
  259.                 if ($i > length $lin) { $i = length $lin; }
  260.                 while ($i > 0 && substr($lin, $i, 1) ne ' ') { $i--; }
  261.                 if ($i == 0) { $i = 70 };
  262.                 if ($i > length $lin) { $i = length $lin; }
  263.                 put(substr($lin, 0, $i));
  264.         $lin = substr($lin, $i + 1);
  265.                 $lin =~ s/^ +//o;
  266.                 $first = 0;
  267.             }
  268.         }
  269.     }
  270. }
  271.  
  272. sub comment {
  273. #my $comm = $_[0];
  274.  
  275. #print $comm;
  276. }
  277.  
  278. sub badtag {
  279. #    my $badtag = $_[0];
  280. #    print "<$badtag>"; # ?
  281. }
  282. __END__
  283. sub tag {
  284.     my $TAG = $_[0];
  285.     my %PARM = %{$_[1]};
  286.     my @ARGS = @{$_[2]};
  287.     
  288.     print "<$TAG";
  289.     foreach $n (@ARGS) {
  290.         $key = $ARGS[$n][2];
  291.         print ' ';
  292.         print $key                             if $ARGS[$n][0] == -1;
  293.         print $key, '=', $ARGS[$n][1]          if $ARGS[$n][0] == 0;
  294.         print $key, '=\'', $ARGS[$n][1], '\''  if $ARGS[$n][0] == 1;
  295.         print $key, '="', $ARGS[$n][1], '"'    if $ARGS[$n][0] == 2;
  296.     }
  297.     print ">\n";
  298. }
  299.  
  300. sub out {
  301.     my $lin = $_[0];
  302.     
  303.     $lin =~ s/\n/ /;
  304.     
  305.     print " |", $lin, "\n";
  306. }
  307.  
  308. sub comment {
  309.     my $comm = $_[0];
  310.  
  311.     print "#|", $comm;
  312. }
  313.  
  314. __END__
  315.