htmllink

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 exit 0 unless(system("plhelp",$0,(@ARGV)));
   5
   6 #http://www.google.com/intl/
   7 sub GetBaseUrl($) {
   8     my $result=shift;
   9     if (! $result) {return "";}
  10     if ($result !~ /^\w+:\/\//i) {
  11         $result = "http://" . $result;
  12         $result =~ s/^http:\/\/\/*/http:\/\//;
  13     }
  14     $result =~ s/(\w+):\/\/(.*)\/[^\/]*$/$1:\/\/$2/;
  15     $result .= "/";
  16     $result =~ s/([^:\/])\/\//$1\//g;
  17     return $result;
  18 }
  19
  20 #http://www.google.com
  21 sub GetRootUrl($) {
  22     my $result=shift;
  23     $result =~ s/(\w+):\/\/([^\/]*).*/$1:\/\/$2/;
  24     return $result;
  25 }
  26
  27 sub FullUrl($$@) {
  28     my $base = shift;
  29     my $root = shift;
  30     my @result=();
  31     foreach(@_) {
  32         my $url=$_;
  33         if ($url =~ /^\//) {
  34             $url = $root . $url;
  35         }
  36         else {
  37             if ($url !~ /^(\w+):\/\//i) {
  38                 $url = $base . $url;
  39             }
  40         }
  41         if ($url !~ /^(\w+):\/\//i) {
  42             $url = "http://" . $url;
  43         }
  44         push @result,$url;
  45     }
  46     return @result;
  47 }
  48
  49
  50 my $BaseUrl=GetBaseUrl($ARGV[0]);
  51 my $RootUrl=GetRootUrl($BaseUrl);
  52
  53 my @urls=();
  54
  55 #sub ripurl
  56 while(<STDIN>) {
  57 #    s/[\n\t]//g;
  58     s/"/'/g;
  59     s/(href|src)\s*=\s*/HREF=/gi;
  60     s/'((http|ftp):\/\/[^']+?)'/HREF='$1'/g;
  61     s/[^']((http|ftp):\/\/[^ \<\>]+)/HREF='$1'/g;
  62     s/HREF=([^'][^ \<\>]+)/HREF='$1'/g;
  63     s/HREF='HREF=/HREF=/g;
  64     my @match = ( $_ =~ /HREF='\s*([^']+?)\s*'/g );
  65     @match = FullUrl($BaseUrl,$RootUrl,@match);# if ($BaseUrl);
  66     foreach(@match) {
  67         print "$_\n";
  68     }
  69 }