vcs.maemo.org Git - pkg-perl/blob - deb-src/libhtml-parser-perl/libhtml-parser-perl-3.56/eg/hrefsub

   1 #!/usr/bin/perl
   2
   3 # Perform transformations on link attributes in an HTML document.
   4 # Examples:
   5 #
   6 #  $ hrefsub 's/foo/bar/g' index.html
   7 #  $ hrefsub '$_=URI->new_abs($_, "http://foo")' index.html
   8 #
   9 # The first argument is a perl expression that might modify $_.
  10 # It is called for each link in the document with $_ set to
  11 # the original value of the link URI.  The variables $tag and
  12 # $attr can be used to access the tagname and attributename
  13 # within the tag where the current link is found.
  14 #
  15 # The second argument is the name of a file to process.
  16
  17 use strict;
  18 use HTML::Parser ();
  19 use URI;
  20
  21 # Construct a hash of tag names that may have links.
  22 my %link_attr;
  23 {
  24     # To simplify things, reformat the %HTML::Tagset::linkElements
  25     # hash so that it is always a hash of hashes.
  26     require HTML::Tagset;
  27     while (my($k,$v) = each %HTML::Tagset::linkElements) {
  28         if (ref($v)) {
  29             $v = { map {$_ => 1} @$v };
  30         }
  31         else {
  32             $v = { $v => 1};
  33         }
  34         $link_attr{$k} = $v;
  35     }
  36     # Uncomment this to see what HTML::Tagset::linkElements thinks are
  37     # the tags with link attributes
  38     #use Data::Dump; Data::Dump::dump(\%link_attr); exit;
  39 }
  40
  41 # Create a subroutine named 'edit' to perform the operation
  42 # passed in from the command line.  The code should modify $_
  43 # to change things.
  44 my $code = shift;
  45 my $code = 'sub edit { local $_ = shift; my($attr, $tag) = @_; no strict; ' .
  46            $code .
  47            '; $_; }';
  48 #print $code;
  49 eval $code;
  50 die $@ if $@;
  51
  52 # Set up the parser.
  53 my $p = HTML::Parser->new(api_version => 3);
  54
  55 # The default is to print everything as is.
  56 $p->handler(default => sub { print @_ }, "text");
  57
  58 # All links are found in start tags.  This handler will evaluate
  59 # &edit for each link attribute found.
  60 $p->handler(start => sub {
  61                 my($tagname, $pos, $text) = @_;
  62                 if (my $link_attr = $link_attr{$tagname}) {
  63                     while (4 <= @$pos) {
  64                         # use attribute sets from right to left
  65                         # to avoid invalidating the offsets
  66                         # when replacing the values
  67                         my($k_offset, $k_len, $v_offset, $v_len) =
  68                             splice(@$pos, -4);
  69                         my $attrname = lc(substr($text, $k_offset, $k_len));
  70                         next unless $link_attr->{$attrname};
  71                         next unless $v_offset; # 0 v_offset means no value
  72                         my $v = substr($text, $v_offset, $v_len);
  73                         $v =~ s/^([\'\"])(.*)\1$/$2/;
  74                         my $new_v = edit($v, $attrname, $tagname);
  75                         next if $new_v eq $v;
  76                         $new_v =~ s/\"/&quot;/g;  # since we quote with ""
  77                         substr($text, $v_offset, $v_len) = qq("$new_v");
  78                     }
  79                 }
  80                 print $text;
  81             },
  82             "tagname, tokenpos, text");
  83
  84 # Parse the file passed in from the command line
  85 my $file = shift || usage();
  86 $p->parse_file($file) || die "Can't open file $file: $!\n";
  87
  88 sub usage
  89 {
  90     my $progname = $0;
  91     $progname =~ s,^.*/,,;
  92     die "Usage: $progname <perlexpr> <filename>\n";
  93 }