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\" failed";
  74     return 3;
  75   }
  76 }
  77
  78 # Returns ($err, $isdir)
  79 # returns 0, x if file does not match entry
  80 #         1, x everything OK
  81 #         2, x if not accesible (permission)
  82 sub check_ftp_dir_entry($$)
  83 {
  84   my ($file, $e) = @_;
  85   my $other = '---';
  86   my $isdir = 0;
  87
  88   #print "Checking '$file' against '$e'\n";
  89   $file =~ s/^\///;
  90   $isdir = 1 if ($e =~ /^d/);
  91   return(0,$isdir) if ($e !~ /\s$file$/);
  92   if ($e =~ /^.[-rwx]{6}([-rwx]{3})\s/) {
  93     $other = $1;
  94   }
  95   else {
  96     #print "Invalid entry\n";
  97     # Invalid entry
  98     return(0,$isdir);
  99   }
 100   return(2,$isdir) if ($other !~ /^r/); # not readable
 101   if ($isdir) {
 102     #return(2,$isdir) if ($other !~ /x$/); # directory, but not executable
 103   }
 104   return(1,$isdir);
 105 }
 106
 107 sub check_ftp_url($$$$)
 108 {
 109   use Net::FTP;
 110
 111   my ($protocol, $host, $path, $file) = @_;
 112   my $res = 0;
 113   my $message = "";
 114
 115   my $ftp = Net::FTP->new($host, Debug => 0, Timeout => 120);
 116   if(!$ftp) {
 117     return(3,"Cannot connect to $host");
 118   }
 119   if (! $ftp->login("anonymous",'-anonymous@')) {
 120     $message = $ftp->message;
 121     $res = 3;
 122   }
 123   else {
 124     my $rEntries;
 125     if ($path ne "") {
 126       #print "Path = $path\n";
 127       #if (!$ftp->cwd($path)) {
 128       # $message = $ftp->message;
 129       # $res = 3;
 130       #}
 131       $rEntries = $ftp->dir($path);
 132     }
 133     else {
 134       $rEntries = $ftp->dir();
 135     }
 136     if (! $rEntries) {
 137       $res = 3;
 138       $message = "Could not read directory \"$path\"";
 139     }
 140     elsif (defined($file)) {
 141       my $found = 0;
 142       my $found2 = 0;
 143       for my $f ( @{$rEntries}) {
 144         #print "Entry: $path $f\n";
 145         my ($res1,$isdir) = check_ftp_dir_entry($file,$f);
 146         if ($res1 == 1) {
 147           $found = 1;
 148           last;
 149         }
 150         elsif ($res1 == 2) {
 151           # found, but not accessible
 152           $found2 = 1;
 153           $message = "Permission denied for '$file'";
 154         }
 155       }
 156       if (! $found) {
 157         $res = 4;
 158         if (! $found2) {
 159           $message = "File or directory '$file' not found";
 160         }
 161       }
 162     }
 163   }
 164   $ftp->quit;
 165   #print "returning ($res,$message)\n";
 166   return($res, $message);
 167 }
 168
 169 sub check_unknown_url($$$$)
 170 {
 171   use LWP::Simple;
 172
 173   my ($protocol, $host, $path, $file) = @_;
 174   my $res = 1;
 175
 176   my $url = "$protocol://$host";
 177   if ($path ne "") {
 178     if ($path =~ /^\//) {
 179       $url .= $path;
 180     }
 181     else {
 182       $url .= "/$path";
 183     }
 184   }
 185   if(defined($file)) {
 186     #print "Trying $url$file\n";
 187     $res = head("$url/$file");
 188     if(! $res) {
 189       # try to check for directory '/';
 190       #print "Trying $url$file/\n";
 191       $res = head("$url/$file/");
 192     }
 193   }
 194   else {
 195     #print "Trying $url\n";
 196     $res = head($url);
 197   }
 198   return(! $res);
 199 }
 200
 201 #
 202 # Main entry
 203 sub check_url($)
 204 {
 205   my($url) = @_;
 206   my $file = undef;
 207   my ($protocol,$host,$path);
 208
 209   my $res = 0;
 210
 211   # Split the url to protocol,host,path
 212   if ($url =~ /^([a-z]+):\/\/([^\/]+)(.*)$/) {
 213     $protocol = $1;
 214     $host = $2;
 215     $path = $3;
 216     $path =~ s/^\///;
 217     if($path =~ s/\/([^\/]+)$//) {
 218       $file = $1;
 219       if($file =~ / /) {
 220         # Filename contains ' ', maybe invalid. Don't check
 221         $file = undef;
 222       }
 223       $path .= "/";
 224     }
 225   }
 226   else {
 227     print " Invalid url '$url'";
 228     return 2;
 229   }
 230   if ($protocol =~ /^https?$/) {
 231     return check_http_url($protocol, $host, $path, $file);
 232   }
 233   elsif ($protocol eq "ftp") {
 234     my $message;
 235     ($res, $message) = check_ftp_url($protocol, $host, $path, $file);
 236     return $res;
 237   }
 238   else {
 239     # it never should reach this point
 240     print " What protocol is '$protocol'?";
 241     $res = check_unknown_url($protocol, $host, $path, $file);
 242     return $res;
 243   }
 244 }
 245
 246 1;