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