home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / doc / libhtml-parser-perl / examples / hrefsub < prev    next >
Encoding:
Text File  |  2008-04-04  |  2.7 KB  |  94 lines
  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/\"/"/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. }
  94.