Last change
on this file since 27174 was 27174, checked in by davidb, 11 years ago |
Perl modules from CPAN that are used in supporting activate.pl, but not part of the Perl core. Only PMs included.
|
File size:
1.4 KB
|
Line | |
---|
1 | package URI::file::Base;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use URI::Escape qw();
|
---|
5 |
|
---|
6 | sub new
|
---|
7 | {
|
---|
8 | my $class = shift;
|
---|
9 | my $path = shift;
|
---|
10 | $path = "" unless defined $path;
|
---|
11 |
|
---|
12 | my($auth, $escaped_auth, $escaped_path);
|
---|
13 |
|
---|
14 | ($auth, $escaped_auth) = $class->_file_extract_authority($path);
|
---|
15 | ($path, $escaped_path) = $class->_file_extract_path($path);
|
---|
16 |
|
---|
17 | if (defined $auth) {
|
---|
18 | $auth =~ s,%,%25,g unless $escaped_auth;
|
---|
19 | $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
|
---|
20 | $auth = "//$auth";
|
---|
21 | if (defined $path) {
|
---|
22 | $path = "/$path" unless substr($path, 0, 1) eq "/";
|
---|
23 | } else {
|
---|
24 | $path = "";
|
---|
25 | }
|
---|
26 | } else {
|
---|
27 | return undef unless defined $path;
|
---|
28 | $auth = "";
|
---|
29 | }
|
---|
30 |
|
---|
31 | $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path;
|
---|
32 | $path =~ s/\#/%23/g;
|
---|
33 |
|
---|
34 | my $uri = $auth . $path;
|
---|
35 | $uri = "file:$uri" if substr($uri, 0, 1) eq "/";
|
---|
36 |
|
---|
37 | URI->new($uri, "file");
|
---|
38 | }
|
---|
39 |
|
---|
40 | sub _file_extract_authority
|
---|
41 | {
|
---|
42 | my($class, $path) = @_;
|
---|
43 | return undef unless $class->_file_is_absolute($path);
|
---|
44 | return $URI::file::DEFAULT_AUTHORITY;
|
---|
45 | }
|
---|
46 |
|
---|
47 | sub _file_extract_path
|
---|
48 | {
|
---|
49 | return undef;
|
---|
50 | }
|
---|
51 |
|
---|
52 | sub _file_is_absolute
|
---|
53 | {
|
---|
54 | return 0;
|
---|
55 | }
|
---|
56 |
|
---|
57 | sub _file_is_localhost
|
---|
58 | {
|
---|
59 | shift; # class
|
---|
60 | my $host = lc(shift);
|
---|
61 | return 1 if $host eq "localhost";
|
---|
62 | eval {
|
---|
63 | require Net::Domain;
|
---|
64 | lc(Net::Domain::hostfqdn()) eq $host ||
|
---|
65 | lc(Net::Domain::hostname()) eq $host;
|
---|
66 | };
|
---|
67 | }
|
---|
68 |
|
---|
69 | sub file
|
---|
70 | {
|
---|
71 | undef;
|
---|
72 | }
|
---|
73 |
|
---|
74 | sub dir
|
---|
75 | {
|
---|
76 | my $self = shift;
|
---|
77 | $self->file(@_);
|
---|
78 | }
|
---|
79 |
|
---|
80 | 1;
|
---|
Note:
See
TracBrowser
for help on using the repository browser.