File Coverage

blib/lib/URI/gopher.pm
Criterion Covered Total %
statement 51 53 96.2
branch 14 20 70.0
condition 1 3 33.3
subroutine 12 12 100.0
pod 1 6 16.6
total 79 94 84.0


line stmt bran cond sub pod time code
1             package URI::gopher; # , Dec 4, 1996
2              
3 3     3   21 use strict;
  3         6  
  3         93  
4 3     3   15 use warnings;
  3         4  
  3         141  
5              
6             our $VERSION = '5.21';
7              
8 3     3   417 use parent 'URI::_server';
  3         283  
  3         18  
9              
10 3     3   150 use URI::Escape qw(uri_unescape);
  3         12  
  3         1829  
11              
12             # A Gopher URL follows the common internet scheme syntax as defined in
13             # section 4.3 of [RFC-URL-SYNTAX]:
14             #
15             # gopher://[:]/
16             #
17             # where
18             #
19             # := |
20             # %09 |
21             # %09%09
22             #
23             # := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7'
24             # '8' | '9' | '+' | 'I' | 'g' | 'T'
25             #
26             # := *pchar Refer to RFC 1808 [4]
27             # := *pchar
28             # := *uchar Refer to RFC 1738 [3]
29             #
30             # If the optional port is omitted, the port defaults to 70.
31              
32 4     4 1 9 sub default_port { 70 }
33              
34             sub _gopher_type
35             {
36 13     13   19 my $self = shift;
37 13         47 my $path = $self->path_query;
38 13         40 $path =~ s,^/,,;
39 13 100       43 my $gtype = $1 if $path =~ s/^(.)//s;
40 13 100       28 if (@_) {
41 1         2 my $new_type = shift;
42 1 50       19 if (defined($new_type)) {
43 1 50       6 Carp::croak("Bad gopher type '$new_type'")
44             unless length($new_type) == 1;
45 1         2 substr($path, 0, 0) = $new_type;
46 1         4 $self->path_query($path);
47             } else {
48 0 0       0 Carp::croak("Can't delete gopher type when selector is present")
49             if length($path);
50 0         0 $self->path_query(undef);
51             }
52             }
53 13         20 return $gtype;
54             }
55              
56             sub gopher_type
57             {
58 13     13 0 24 my $self = shift;
59 13         27 my $gtype = $self->_gopher_type(@_);
60 13 100       31 $gtype = "1" unless defined $gtype;
61 13         47 $gtype;
62             }
63              
64 5     5 0 18 sub gtype { goto &gopher_type } # URI::URL compatibility
65              
66 11     11 0 31 sub selector { shift->_gfield(0, @_) }
67 10     10 0 29 sub search { shift->_gfield(1, @_) }
68 1     1 0 3 sub string { shift->_gfield(2, @_) }
69              
70             sub _gfield
71             {
72 22     22   27 my $self = shift;
73 22         25 my $fno = shift;
74 22         59 my $path = $self->path_query;
75              
76             # not according to spec., but many popular browsers accept
77             # gopher URLs with a '?' before the search string.
78 22         45 $path =~ s/\?/\t/;
79 22         57 $path = uri_unescape($path);
80 22         64 $path =~ s,^/,,;
81 22 100       74 my $gtype = $1 if $path =~ s,^(.),,s;
82 22         58 my @path = split(/\t/, $path, 3);
83 22 100       45 if (@_) {
84             # modify
85 2         4 my $new = shift;
86 2         4 $path[$fno] = $new;
87 2   33     10 pop(@path) while @path && !defined($path[-1]);
88 2 50       5 for (@path) { $_="" unless defined }
  3         7  
89 2         3 $path = $gtype;
90 2 50       5 $path = "1" unless defined $path;
91 2         4 $path .= join("\t", @path);
92 2         5 $self->path_query($path);
93             }
94 22         102 $path[$fno];
95             }
96              
97             1;