development/checkurls/CheckURL.pm

   1 # -*- mode: perl; -*-
   2 package CheckURL;
   3 # file CheckURL.pm
   4 #
   5 # This file is part of LyX, the document processor.
   6 # Licence details can be found in the file COPYING.
   7 #
   8 # authors: Kornel Benko <kornel@lyx.org>
   9 #          Scott Kostyshak <skotysh@lyx.org>
  10 #
  11
  12 # Check if given URL exists and is accessible
  13 #
  14 use strict;
  15
  16 our(@EXPORT, @ISA);
  17 BEGIN {
  18   use Exporter   ();
  19   @ISA    = qw(Exporter);
  20   @EXPORT = qw(check_url);
  21 }
  22
  23 # Prototypes
  24 sub check_http_url($$$$);
  25 sub check_ftp_dir_entry($$);
  26 sub check_ftp_url($$$$);
  27 sub check_unknown_url($$$$);
  28 sub check_url($);
  29 ################
  30
  31 sub check_http_url($$$$)
  32 {
  33   use Net::HTTP;
  34   use Net::HTTPS;
  35
  36   my ($protocol, $host, $path, $file) = @_;
  37
  38   my $s;
  39   if ($protocol eq "http") {
  40     $s = Net::HTTP->new(Host => $host, Timeout => 120);
  41   }
  42   elsif ($protocol eq "https") {
  43     $s = Net::HTTPS->new(Host => $host, Timeout => 120);
  44   }
  45   else {
  46     print " Unhandled http protocol \"$protocol\"";
  47     return 3;
  48   }
  49   if (! $s) {
  50     print " " . $@;
  51     return 3;
  52   }
  53   my $getp = "/";
  54   if ($path ne "") {
  55     $getp .= $path;
  56   }
  57   if (defined($file)) {
  58     if ($getp =~ /\/$/) {
  59       $getp .= $file;
  60     }
  61     else {
  62       $getp .= "/$file";
  63     }
  64   }
  65   #print " Trying to use GET  => \"$getp\"";
  66   $s->write_request(GET => $getp, 'User-Agent' => "Mozilla/6.0");
  67   my($code, $mess, %h) = $s->read_response_headers;
  68
  69   # Try to read something
  70   my $buf;
  71   my $n = $s->read_entity_body($buf, 1024);
  72   if (! defined($n)) {
  73     print " Read from \"$protocol://$host$getp\" ";
  74     return 3;
  75   }
  76   if ($buf =~ /\<title\>Error 404\<\/title\>/) {
  77     print " Page reports 'Error 404' from \"$protocol://$host$getp\" ";
  78     return 3;
  79   }
  80   return 0;
  81 }
  82
  83 # Returns ($err, $isdir)
  84 # returns 0, x if file does not match entry
  85 #         1, x everything OK
  86 #         2, x if not accesible (permission)
  87 sub check_ftp_dir_entry($$)
  88 {
  89   my ($file, $e) = @_;
  90   my $other = '---';
  91   my $isdir = 0;
  92
  93   #print "Checking '$file' against '$e'\n";
  94   $file =~ s/^\///;
  95   $isdir = 1 if ($e =~ /^d/);
  96   return(0,$isdir) if ($e !~ /\s$file$/);
  97   if ($e =~ /^.[-rwx]{6}([-rwx]{3})\s/) {
  98     $other = $1;
  99   }
 100   else {
 101     #print "Invalid entry\n";
 102     # Invalid entry
 103     return(0,$isdir);
 104   }
 105   return(2,$isdir) if ($other !~ /^r/); # not readable
 106   if ($isdir) {
 107     #return(2,$isdir) if ($other !~ /x$/); # directory, but not executable
 108   }
 109   return(1,$isdir);
 110 }
 111
 112 sub check_ftp_url($$$$)
 113 {
 114   use Net::FTP;
 115
 116   my ($protocol, $host, $path, $file) = @_;
 117   my $res = 0;
 118   my $message = "";
 119
 120   my $ftp = Net::FTP->new($host, Debug => 0, Timeout => 120);
 121   if(!$ftp) {
 122     return(3,"Cannot connect to $host");
 123   }
 124   if (! $ftp->login("anonymous",'-anonymous@')) {
 125     $message = $ftp->message;
 126     $res = 3;
 127   }
 128   else {
 129     my $rEntries;
 130     if ($path ne "") {
 131       #print "Path = $path\n";
 132       #if (!$ftp->cwd($path)) {
 133       # $message = $ftp->message;
 134       # $res = 3;
 135       #}
 136       $rEntries = $ftp->dir($path);
 137     }
 138     else {
 139       $rEntries = $ftp->dir();
 140     }
 141     if (! $rEntries) {
 142       $res = 3;
 143       $message = "Could not read directory \"$path\"";
 144     }
 145     elsif (defined($file)) {
 146       my $found = 0;
 147       my $found2 = 0;
 148       for my $f ( @{$rEntries}) {
 149         #print "Entry: $path $f\n";
 150         my ($res1,$isdir) = check_ftp_dir_entry($file,$f);
 151         if ($res1 == 1) {
 152           $found = 1;
 153           last;
 154         }
 155         elsif ($res1 == 2) {
 156           # found, but not accessible
 157           $found2 = 1;
 158           $message = "Permission denied for '$file'";
 159         }
 160       }
 161       if (! $found) {
 162         $res = 4;
 163         if (! $found2) {
 164           $message = "File or directory '$file' not found";
 165         }
 166       }
 167     }
 168   }
 169   $ftp->quit;
 170   #print "returning ($res,$message)\n";
 171   return($res, $message);
 172 }
 173
 174 sub check_unknown_url($$$$)
 175 {
 176   use LWP::Simple;
 177
 178   my ($protocol, $host, $path, $file) = @_;
 179   my $res = 1;
 180
 181   my $url = "$protocol://$host";
 182   if ($path ne "") {
 183     if ($path =~ /^\//) {
 184       $url .= $path;
 185     }
 186     else {
 187       $url .= "/$path";
 188     }
 189   }
 190   if(defined($file)) {
 191     #print "Trying $url$file\n";
 192     $res = head("$url/$file");
 193     if(! $res) {
 194       # try to check for directory '/';
 195       #print "Trying $url$file/\n";
 196       $res = head("$url/$file/");
 197     }
 198   }
 199   else {
 200     #print "Trying $url\n";
 201     $res = head($url);
 202   }
 203   return(! $res);
 204 }
 205
 206 #
 207 # Main entry
 208 sub check_url($)
 209 {
 210   my($url) = @_;
 211   my $file = undef;
 212   my ($protocol,$host,$path);
 213
 214   my $res = 0;
 215
 216   # Split the url to protocol,host,path
 217   if ($url =~ /^([a-z]+):\/\/([^\/]+)(.*)$/) {
 218     $protocol = $1;
 219     $host = $2;
 220     $path = $3;
 221     $path =~ s/^\///;
 222     if($path =~ s/\/([^\/]+)$//) {
 223       $file = $1;
 224       if($file =~ / /) {
 225         # Filename contains ' ', maybe invalid. Don't check
 226         $file = undef;
 227       }
 228       $path .= "/";
 229     }
 230   }
 231   else {
 232     print " Invalid url '$url'";
 233     return 2;
 234   }
 235   if ($protocol =~ /^https?$/) {
 236     return check_http_url($protocol, $host, $path, $file);
 237   }
 238   elsif ($protocol eq "ftp") {
 239     my $message;
 240     ($res, $message) = check_ftp_url($protocol, $host, $path, $file);
 241     return $res;
 242   }
 243   else {
 244     # it never should reach this point
 245     print " What protocol is '$protocol'?";
 246     $res = check_unknown_url($protocol, $host, $path, $file);
 247     return $res;
 248   }
 249 }
 250
 251 1;