5 # This file is part of LyX, the document processor.
6 # Licence details can be found in the file COPYING.
8 # authors: Kornel Benko <kornel@lyx.org>
9 # Scott Kostyshak <skotysh@lyx.org>
12 # Check if given URL exists and is accessible
20 @EXPORT = qw(check_url);
23 sub check_http_url($$$$)
28 my ($protocol, $host, $path, $file) = @_;
31 if ($protocol eq "http") {
32 $s = Net::HTTP->new(Host => $host, Timeout => 120);
34 elsif ($protocol eq "https") {
35 $s = Net::HTTPS->new(Host => $host, Timeout => 120);
38 print " Unhandled http protocol \"$protocol\"";
57 #print " Trying to use GET => \"$getp\"";
58 $s->write_request(GET => $getp, 'User-Agent' => "Mozilla/6.0");
59 my($code, $mess, %h) = $s->read_response_headers;
61 # Try to read something
63 my $n = $s->read_entity_body($buf, 1024);
65 print " Read from \"$protocol://$host$getp\" failed";
70 # Returns ($err, $isdir)
71 # returns 0, x if file does not match entry
73 # 2, x if not accesible (permission)
74 sub check_ftp_dir_entry($$)
80 #print "Checking '$file' against '$e'\n";
82 $isdir = 1 if ($e =~ /^d/);
83 return(0,$isdir) if ($e !~ /\s$file$/);
84 if ($e =~ /^.[-rwx]{6}([-rwx]{3})\s/) {
88 #print "Invalid entry\n";
92 return(2,$isdir) if ($other !~ /^r/); # not readable
94 #return(2,$isdir) if ($other !~ /x$/); # directory, but not executable
99 sub check_ftp_url($$$$)
103 my ($protocol, $host, $path, $file) = @_;
107 my $ftp = Net::FTP->new($host, Debug => 0, Timeout => 120);
109 return(3,"Cannot connect to $host");
111 if (! $ftp->login("anonymous",'-anonymous@')) {
112 $message = $ftp->message;
118 #print "Path = $path\n";
119 #if (!$ftp->cwd($path)) {
120 # $message = $ftp->message;
123 $rEntries = $ftp->dir($path);
126 $rEntries = $ftp->dir();
130 $message = "Could not read directory \"$path\"";
132 elsif (defined($file)) {
135 for my $f ( @{$rEntries}) {
136 #print "Entry: $path $f\n";
137 my ($res1,$isdir) = &check_ftp_dir_entry($file,$f);
143 # found, but not accessible
145 $message = "Permission denied for '$file'";
151 $message = "File or directory '$file' not found";
157 #print "returning ($res,$message)\n";
158 return($res, $message);
161 sub check_unknown_url($$$$)
165 my ($protocol, $host, $path, $file) = @_;
168 my $url = "$protocol://$host";
170 if ($path =~ /^\//) {
178 #print "Trying $url$file\n";
179 $res = head("$url/$file");
181 # try to check for directory '/';
182 #print "Trying $url$file/\n";
183 $res = head("$url/$file/");
187 #print "Trying $url\n";
199 my ($protocol,$host,$path);
203 # Split the url to protocol,host,path
204 if ($url =~ /^([a-z]+):\/\/([^\/]+)(.*)$/) {
209 if($path =~ s/\/([^\/]+)$//) {
212 # Filename contains ' ', maybe invalid. Don't check
219 print " Invalid url '$url'";
222 if ($protocol =~ /^https?$/) {
223 return &check_http_url($protocol, $host, $path, $file);
225 elsif ($protocol eq "ftp") {
227 ($res, $message) = &check_ftp_url($protocol, $host, $path, $file);
231 # it never should reach this point
232 print " What protocol is '$protocol'?";
233 $res = &check_unknown_url($protocol, $host, $path, $file);