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   require LWP::UserAgent;
  34
  35   my ($protocol, $host, $path, $file) = @_;
  36
  37   my $ua = LWP::UserAgent->new;
  38   my $getp = "/";
  39   if ($path ne "") {
  40     $getp .= $path;
  41   }
  42   if (defined($file)) {
  43     if ($getp =~ /\/$/) {
  44       $getp .= $file;
  45     }
  46     else {
  47       $getp .= "/$file";
  48     }
  49   }
  50   my $buf;
  51   $ua->agent("Firefox/43.0");
  52   my $response = $ua->get("$protocol://$host$getp");
  53   if ($response->is_success) {
  54     $buf = $response->decoded_content;
  55   }
  56   else {
  57     print " " . $response->status_line . ": ";
  58     return 3;
  59   }
  60   my @title = ();
  61   my $res = 0;
  62   while ($buf =~ s/\<title\>([^\<]*)\<\/title\>//i) {
  63     my $title = $1;
  64     $title =~ s/[\r\n]/ /g;
  65     $title =~ s/  +/ /g;
  66     $title =~ s/^ //;
  67     $title =~ s/ $//;
  68     push(@title, $title);
  69     print "title = \"$title\": ";
  70     if ($title =~ /Error 404|Not Found/) {
  71       print " Page reports 'Not Found' from \"$protocol://$host$getp\": ";
  72       $res = 3;
  73     }
  74   }
  75   return $res;
  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_ftp2_url($$$$)
 108 {
 109   my ($protocol, $host, $path, $file) = @_;
 110
 111   my $checkentry = 1;
 112   print "\nhost $host\n";
 113   print "path $path\n";
 114   print "file $file\n";
 115   my $url = "$protocol://$host";
 116   $path =~ s/\/$//;
 117   if (defined($file)) {
 118     $url = "$url/$path/$file";
 119   }
 120   else {
 121     $url = "$url/$path/.";
 122   }
 123   print "curl $url, file = $file\n";
 124   my %listfiles = ();
 125   if (open(FFTP, "curl --anyauth -l $url|")) {
 126     while (my $l = <FFTP>) {
 127       chomp($l);
 128       $listfiles{$l} = 1;
 129     }
 130     close(FFTP);
 131   }
 132   if (%listfiles) {
 133     if (! defined($file)) {
 134       return(0, "OK");
 135     }
 136     elsif (defined($listfiles{$file})) {
 137       return(0, "OK");
 138     }
 139     elsif (defined($listfiles{"ftpinfo.txt"})) {
 140       return(0, "Probably a directory");
 141     }
 142     else {
 143       return(1, "Not found");
 144     }
 145   }
 146   else {
 147     return(1, "Error");
 148   }
 149 }
 150
 151 sub check_ftp_url($$$$)
 152 {
 153   use Net::FTP;
 154
 155   my ($protocol, $host, $path, $file) = @_;
 156   my $res = 0;
 157   my $message = "";
 158
 159   my $ftp = Net::FTP->new($host, Debug => 0, Timeout => 120);
 160   if(!$ftp) {
 161     return(3,"Cannot connect to $host");
 162   }
 163   if (! $ftp->login("anonymous",'-anonymous@')) {
 164     $message = $ftp->message;
 165     $res = 3;
 166   }
 167   else {
 168     my $rEntries;
 169     if ($path ne "") {
 170       #print "Path = $path\n";
 171       #if (!$ftp->cwd($path)) {
 172       # $message = $ftp->message;
 173       # $res = 3;
 174       #}
 175       $rEntries = $ftp->dir($path);
 176     }
 177     else {
 178       $rEntries = $ftp->dir();
 179     }
 180     if (! $rEntries) {
 181       $res = 3;
 182       $message = "Could not read directory \"$path\"";
 183     }
 184     elsif (defined($file)) {
 185       my $found = 0;
 186       my $found2 = 0;
 187       for my $f ( @{$rEntries}) {
 188         #print "Entry: $path $f\n";
 189         my ($res1,$isdir) = check_ftp_dir_entry($file,$f);
 190         if ($res1 == 1) {
 191           $found = 1;
 192           last;
 193         }
 194         elsif ($res1 == 2) {
 195           # found, but not accessible
 196           $found2 = 1;
 197           $message = "Permission denied for '$file'";
 198         }
 199       }
 200       if (! $found) {
 201         $res = 4;
 202         if (! $found2) {
 203           $message = "File or directory '$file' not found";
 204         }
 205       }
 206     }
 207   }
 208   $ftp->quit;
 209   #print "returning ($res,$message)\n";
 210   return($res, $message);
 211 }
 212
 213 sub check_unknown_url($$$$)
 214 {
 215   use LWP::Simple;
 216
 217   my ($protocol, $host, $path, $file) = @_;
 218   my $res = 1;
 219
 220   my $url = "$protocol://$host";
 221   if ($path ne "") {
 222     if ($path =~ /^\//) {
 223       $url .= $path;
 224     }
 225     else {
 226       $url .= "/$path";
 227     }
 228   }
 229   if(defined($file)) {
 230     #print "Trying $url$file\n";
 231     $res = head("$url/$file");
 232     if(! $res) {
 233       # try to check for directory '/';
 234       #print "Trying $url$file/\n";
 235       $res = head("$url/$file/");
 236     }
 237   }
 238   else {
 239     #print "Trying $url\n";
 240     $res = head($url);
 241   }
 242   return(! $res);
 243 }
 244
 245 #
 246 # Main entry
 247 sub check_url($$)
 248 {
 249   my($url,$use_curl) = @_;
 250   my $file = undef;
 251   my ($protocol,$host,$path);
 252
 253   my $res = 0;
 254
 255   # Split the url to protocol,host,path
 256   if ($url =~ /^([a-z]+):\/\/([^\/]+)(.*)$/) {
 257     $protocol = $1;
 258     $host = $2;
 259     $path = $3;
 260     $path =~ s/^\///;
 261     if($path =~ s/\/([^\/]+)$//) {
 262       $file = $1;
 263       if($file =~ / /) {
 264         # Filename contains ' ', maybe invalid. Don't check
 265         $file = undef;
 266       }
 267       $path .= "/";
 268     }
 269   }
 270   else {
 271     print " Invalid url '$url'";
 272     return 2;
 273   }
 274   if ($protocol =~ /^https?$/) {
 275     return check_http_url($protocol, $host, $path, $file);
 276   }
 277   elsif ($protocol eq "ftp") {
 278     my $message;
 279     if ($use_curl) {
 280       ($res, $message) = check_ftp2_url($protocol, $host, $path, $file);
 281     }
 282     else {
 283       ($res, $message) = check_ftp_url($protocol, $host, $path, $file);
 284     }
 285     return $res;
 286   }
 287   else {
 288     # it never should reach this point
 289     print " What protocol is '$protocol'?";
 290     $res = check_unknown_url($protocol, $host, $path, $file);
 291     return $res;
 292   }
 293 }
 294
 295 1;