html2cgi

   1 #!/usr/bin/env perl
   2
   3 # html2cgi
   4 # File ID: d7733f9c-7c0d-11df-aac0-90e6ba3022ac
   5
   6 use strict;
   7 use warnings;
   8 $|++;
   9
  10 use HTML::TreeBuilder;
  11 use CGI "-no_debug";
  12
  13 @ARGV = "-" unless @ARGV;
  14
  15 my %SEEN = map { $_, 1 } qw(header comment :html);
  16 my %KNOWN = map { $_, 1 } CGI::expand_tags(":html"); # CHEAT
  17
  18 {
  19   my $h = HTML::TreeBuilder->new;
  20   $h->parse_file(shift);
  21   $h->traverse(\&walker);
  22   $h->delete;
  23   print "use CGI ", S("-no_debug", sort keys %SEEN), ";\nprint header,\n";
  24   print getput();
  25   print ";\n";
  26 }
  27
  28 ## subroutines
  29
  30 sub S {
  31   join ", ",
  32   map {
  33     local $_ = $_;
  34     s/([^ !#%-?A-~])/sprintf "\\x%02x", ord $1/ge;
  35     qq{"$_"};
  36   } @_;
  37 }
  38
  39 BEGIN {                         # scope for static local
  40   my $put_buffer = "";
  41
  42   sub put {
  43     for (@_) {
  44       $put_buffer .= $_;
  45     }
  46   }
  47
  48   sub getput {
  49     ($put_buffer."", $put_buffer = "")[0];
  50   }
  51 }
  52
  53 sub dumpattrs {
  54   my ($open, $hr, $close) = @_;
  55   my @attrs = sort grep !/^_/, keys %$hr;
  56   if (@attrs) {
  57     put
  58       $open,
  59       join(", ", map { S($_)." => ".S($hr->{$_}) } @attrs),
  60       $close;
  61   }
  62 }
  63
  64 BEGIN {                         # scope for static local
  65   my $head_attrs = {};
  66
  67   sub walker {
  68     my ($node, $start, $depth) = @_;
  69     if (ref $node) {
  70       my $tag = $node->tag;
  71       return 1 if $tag eq "html";
  72       if ($tag eq "head") {
  73         $head_attrs = get_attrs_from($node);
  74         return 0;
  75       }
  76       $tag = ucfirst $tag if index(" select tr link delete ", " $tag ") >= 0;
  77       put " " x $depth;
  78       if ($tag eq "body") {
  79         if ($start) {
  80           put "start_html";
  81           dumpattrs "(", $head_attrs, ")";
  82           put ",\n";
  83         } else {
  84           put "end_html,\n";
  85         }
  86         return 1;
  87       }
  88       $SEEN{$tag}++ unless $KNOWN{$tag};
  89       if ($start) {             # start
  90         put "$tag (";
  91         dumpattrs "{", $node, "}, "; # CHEAT
  92       }
  93       if (not $start or $HTML::Element::emptyElement{lc $tag}) { # CHEAT
  94         put S(" ") if not $start and $node->is_empty;
  95         put "), \"\\n\",";
  96       }
  97     } else {                    # text
  98       put " " x $depth, S($node), ", ";
  99     }
 100     put "\n";
 101     return 1;                           # yes, recurse
 102   }
 103 }
 104
 105 sub get_attrs_from {
 106   my $node = shift;
 107   my %return;
 108   for my $first (@{$node->content}) {
 109     next unless ref $first;     # invalid content
 110     my $tag = $first->tag;
 111     if ($tag eq "title") {
 112       $return{"-title"} = join " ", @{$first->content};
 113       next;
 114     }
 115     warn "## unknown head tag: ".($first->as_HTML);
 116   }
 117   return \%return;
 118 }
 119
 120 sub HTML::TreeBuilder::comment { # CHEAT
 121   my $self = shift;
 122   my $pos = $self->{'_pos'};
 123   $pos = $self unless defined($pos);
 124   my $ele = HTML::Element->new('comment');
 125   $ele->push_content(shift);
 126   $pos->push_content($ele);
 127 }