File Coverage

blib/lib/Metabrik/String/Uri.pm
Criterion Covered Total %
statement 9 68 13.2
branch 0 18 0.0
condition 0 32 0.0
subroutine 3 26 11.5
pod 1 21 4.7
total 13 165 7.8


line stmt bran cond sub pod time code
1             #
2             # $Id$
3             #
4             # string::uri Brik
5             #
6             package Metabrik::String::Uri;
7 2     2   691 use strict;
  2         4  
  2         55  
8 2     2   12 use warnings;
  2         3  
  2         52  
9              
10 2     2   10 use base qw(Metabrik);
  2         4  
  2         2233  
11              
12             sub brik_properties {
13             return {
14 0     0 1   revision => '$Revision$',
15             tags => [ qw(unstable encode decode escape) ],
16             author => 'GomoR ',
17             license => 'http://opensource.org/licenses/BSD-3-Clause',
18             attributes => {
19             uri => [ qw(uri) ],
20             },
21             commands => {
22             parse => [ qw(uri|OPTIONAL) ],
23             scheme => [ ],
24             host => [ ],
25             port => [ ],
26             tld => [ ],
27             domain => [ ],
28             hostname => [ ],
29             path => [ ],
30             opaque => [ ],
31             fragment => [ ],
32             query => [ ],
33             path_query => [ ],
34             authority => [ ],
35             query_form => [ ],
36             userinfo => [ ],
37             is_http_scheme => [ ],
38             is_https_scheme => [ ],
39             is_imap_scheme => [ ],
40             is_imaps_scheme => [ ],
41             is_pop3_scheme => [ ],
42             is_pop3s_scheme => [ ],
43             encode => [ qw($data) ],
44             decode => [ qw($data) ],
45             },
46             require_modules => {
47             'URI' => [ ],
48             'URI::Escape' => [ ],
49             },
50             };
51             }
52              
53             sub parse {
54 0     0 0   my $self = shift;
55 0           my ($string) = @_;
56              
57 0   0       $string ||= $self->uri;
58 0 0         $self->brik_help_run_undef_arg('parse', $string) or return;
59              
60 0           my $uri = URI->new($string);
61              
62             # Probably not a valid uri
63 0 0         if (! $uri->can('host')) {
64 0           return $self->log->error("parse: invalid URI [$string]");
65             }
66              
67 0   0       my $h = {
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
68             scheme => $uri->scheme || '',
69             host => $uri->host || '',
70             port => $uri->port || 80,
71             path => $uri->path || '/',
72             opaque => $uri->opaque || '',
73             fragment => $uri->fragment || '',
74             query => $uri->query || '',
75             path_query => $uri->path_query || '',
76             query_form => $uri->query_form || '',
77             userinfo => $uri->userinfo || '',
78             authority => $uri->authority || '',
79             };
80              
81 0 0         if ($h->{userinfo}) {
82 0           my ($user, $password) = $h->{userinfo} =~ m{^(.*):(.*)$};
83 0   0       $h->{user} = $user || '';
84 0   0       $h->{password} = $password || '';
85             }
86              
87 0           return $h;
88             }
89              
90             sub _is_scheme {
91 0     0     my $self = shift;
92 0           my ($parsed, $scheme) = @_;
93              
94 0 0         $self->brik_help_run_undef_arg("is_${scheme}_scheme", $parsed) or return;
95 0 0         $self->brik_help_run_invalid_arg("is_${scheme}_scheme", $parsed, 'HASH') or return;
96              
97 0 0 0       if (exists($parsed->{scheme}) && $parsed->{scheme} eq $scheme) {
98 0           return 1;
99             }
100              
101 0           return 0;
102             }
103              
104             sub is_http_scheme {
105 0     0 0   my $self = shift;
106              
107 0           return $self->_is_scheme(@_, 'http');
108             }
109              
110             sub is_https_scheme {
111 0     0 0   my $self = shift;
112              
113 0           return $self->_is_scheme(@_, 'https');
114             }
115              
116             sub is_imap_scheme {
117 0     0 0   my $self = shift;
118              
119 0           return $self->_is_scheme(@_, 'imap');
120             }
121              
122             sub is_imaps_scheme {
123 0     0 0   my $self = shift;
124              
125 0           return $self->_is_scheme(@_, 'imaps');
126             }
127              
128             sub is_pop3_scheme {
129 0     0 0   my $self = shift;
130              
131 0           return $self->_is_scheme(@_, 'pop3');
132             }
133              
134             sub is_pop3s_scheme {
135 0     0 0   my $self = shift;
136              
137 0           return $self->_is_scheme(@_, 'pop3s');
138             }
139              
140             sub _this {
141 0     0     my $self = shift;
142 0           my ($this) = @_;
143              
144 0           my $uri = $self->uri;
145 0 0         $self->brik_help_run_undef_arg('parse', $uri) or return;
146              
147 0           return $uri->$this;
148             }
149              
150 0     0 0   sub scheme { return shift->_this('scheme'); }
151 0     0 0   sub host { return shift->_this('host'); }
152 0     0 0   sub port { return shift->_this('port'); }
153 0     0 0   sub path { return shift->_this('path'); }
154 0     0 0   sub opaque { return shift->_this('opaque'); }
155 0     0 0   sub fragment { return shift->_this('fragment'); }
156 0     0 0   sub query { return shift->_this('query'); }
157 0     0 0   sub path_query { return shift->_this('path_query'); }
158 0     0 0   sub authority { return shift->_this('authority'); }
159 0     0 0   sub query_form { return shift->_this('query_form'); }
160 0     0 0   sub userinfo { return shift->_this('userinfo'); }
161              
162             sub encode {
163 0     0 0   my $self = shift;
164 0           my ($data) = @_;
165              
166 0 0         $self->brik_help_run_undef_arg('encode', $data) or return;
167              
168 0           my $encoded = URI::Escape::uri_escape($data);
169              
170 0           return $encoded;
171             }
172              
173             sub decode {
174 0     0 0   my $self = shift;
175 0           my ($data) = @_;
176              
177 0 0         $self->brik_help_run_undef_arg('decode', $data) or return;
178              
179 0           my $decoded = URI::Escape::uri_unescape($data);
180              
181 0           return $decoded;
182             }
183              
184             1;
185              
186             __END__