File Coverage

blib/lib/Net/OpenID/Common.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1              
2             package Net::OpenID::Common;
3             {
4             $Net::OpenID::Common::VERSION = '1.18';
5             }
6              
7             =head1 NAME
8              
9             Net::OpenID::Common - Libraries shared between Net::OpenID::Consumer and Net::OpenID::Server
10              
11             =head1 VERSION
12              
13             version 1.18
14              
15             =head1 DESCRIPTION
16              
17             The Consumer and Server implementations share a few libraries which live with this module. This module is here largely to hold the version number and this documentation, though it also incorporates some utility functions inherited from previous versions of L.
18              
19             =head1 COPYRIGHT
20              
21             This package is Copyright (c) 2005 Brad Fitzpatrick, and (c) 2008 Martin Atkins. All rights reserved.
22              
23             You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. If you need more liberal licensing terms, please contact the maintainer.
24              
25             =head1 AUTHORS
26              
27             Brad Fitzpatrick
28              
29             Tatsuhiko Miyagawa
30              
31             Martin Atkins
32              
33             Robert Norris
34              
35             Roger Crew
36              
37             =head1 MAINTAINER
38              
39             Maintained by Roger Crew
40              
41             =cut
42              
43             # This package should totally be called Net::OpenID::util, but
44             # it was historically named wrong so we're just leaving it
45             # like this to avoid confusion.
46             package OpenID::util;
47             {
48             $OpenID::util::VERSION = '1.18';
49             }
50              
51 6     6   196403 use Crypt::DH::GMP;
  0            
  0            
52             use Math::BigInt;
53             use Time::Local ();
54             use MIME::Base64 ();
55             use URI::Escape ();
56             use HTML::Parser ();
57              
58             use constant VERSION_1_NAMESPACE => "http://openid.net/signon/1.1";
59             use constant VERSION_2_NAMESPACE => "http://specs.openid.net/auth/2.0";
60              
61             # I guess this is a bit daft since constants are subs anyway,
62             # but whatever.
63             sub version_1_namespace {
64             return VERSION_1_NAMESPACE;
65             }
66             sub version_2_namespace {
67             return VERSION_2_NAMESPACE;
68             }
69             sub version_1_xrds_service_url {
70             return VERSION_1_NAMESPACE;
71             }
72             sub version_2_xrds_service_url {
73             return "http://specs.openid.net/auth/2.0/signon";
74             }
75             sub version_2_xrds_directed_service_url {
76             return "http://specs.openid.net/auth/2.0/server";
77             }
78             sub version_2_identifier_select_url {
79             return "http://specs.openid.net/auth/2.0/identifier_select";
80             }
81              
82             sub parse_keyvalue {
83             my $reply = shift;
84             my %ret;
85             $reply =~ s/\r//g;
86             foreach (split /\n/, $reply) {
87             next unless /^(\S+?):(.*)/;
88             $ret{$1} = $2;
89             }
90             return %ret;
91             }
92              
93             sub eurl
94             {
95             my $a = $_[0];
96             $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
97             $a =~ tr/ /+/;
98             return $a;
99             }
100              
101             sub push_url_arg {
102             my $uref = shift;
103             $$uref =~ s/[&?]$//;
104             my $got_qmark = ($$uref =~ /\?/);
105              
106             while (@_) {
107             my $key = shift;
108             my $value = shift;
109             $$uref .= $got_qmark ? "&" : ($got_qmark = 1, "?");
110             $$uref .= URI::Escape::uri_escape($key) . "=" . URI::Escape::uri_escape($value);
111             }
112             }
113              
114             sub push_openid2_url_arg {
115             my $uref = shift;
116             my %args = @_;
117             push_url_arg($uref,
118             'openid.ns' => VERSION_2_NAMESPACE,
119             map {
120             'openid.'.$_ => $args{$_}
121             } keys %args,
122             );
123             }
124              
125             sub time_to_w3c {
126             my $time = shift || time();
127             my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
128             $mon++;
129             $year += 1900;
130              
131             return sprintf("%04d-%02d-%02dT%02d:%02d:%02dZ",
132             $year, $mon, $mday,
133             $hour, $min, $sec);
134             }
135              
136             sub w3c_to_time {
137             my $hms = shift;
138             return 0 unless
139             $hms =~ /^(\d{4,4})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)Z$/;
140              
141             my $time;
142             eval {
143             $time = Time::Local::timegm($6, $5, $4, $3, $2 - 1, $1);
144             };
145             return 0 if $@;
146             return $time;
147             }
148              
149             sub int2bytes {
150             my ($int) = @_;
151              
152             my $bigint = Math::BigInt->new($int);
153              
154             die "Can't deal with negative numbers" if $bigint->is_negative;
155              
156             my $bits = $bigint->as_bin;
157             die unless $bits =~ s/^0b//;
158              
159             # prepend zeros to round to byte boundary, or to unset high bit
160             my $prepend = (8 - length($bits) % 8) || ($bits =~ /^1/ ? 8 : 0);
161             $bits = ("0" x $prepend) . $bits if $prepend;
162              
163             return pack("B*", $bits);
164             }
165              
166             sub int2arg {
167             return b64(int2bytes($_[0]));
168             }
169              
170             sub b64 {
171             my $val = MIME::Base64::encode_base64($_[0]);
172             $val =~ s/\s+//g;
173             return $val;
174             }
175              
176             sub d64 {
177             return MIME::Base64::decode_base64($_[0]);
178             }
179              
180             sub bytes2int {
181             return Math::BigInt->new("0b" . unpack("B*", $_[0]))->bstr;
182             }
183              
184             sub arg2int {
185             my ($arg) = @_;
186             return undef unless defined $arg and $arg ne "";
187             # don't acccept base-64 encoded numbers over 700 bytes. which means
188             # those over 4200 bits.
189             return 0 if length($arg) > 700;
190             return bytes2int(MIME::Base64::decode_base64($arg));
191             }
192              
193             sub timing_indep_eq {
194             no warnings 'uninitialized';
195             my ($x, $y)=@_;
196             warnings::warn('uninitialized','Use of uninitialized value in timing_indep_eq')
197             if (warnings::enabled('uninitialized') && !(defined($x) && defined($y)));
198              
199             return '' if length($x)!=length($y);
200              
201             my $n=length($x);
202              
203             my $result=0;
204             for (my $i=0; $i<$n; $i++) {
205             $result |= ord(substr($x, $i, 1)) ^ ord(substr($y, $i, 1));
206             }
207              
208             return !$result;
209             }
210              
211             sub get_dh {
212             my ($p, $g) = @_;
213              
214             $p ||= "155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443";
215             $g ||= "2";
216              
217             return if $p <= 10 or $g <= 1;
218              
219             my $dh = Crypt::DH::GMP->new(p => $p, g => $g);
220             $dh->generate_keys;
221              
222             return $dh;
223             }
224              
225              
226             ################################################################
227             # HTML parsing
228             #
229             # This is a stripped-down version of HTML::HeadParser
230             # that only recognizes and tags
231              
232             our @_linkmeta_parser_options =
233             (
234             api_version => 3,
235             ignore_elements => [qw(script style base isindex command noscript title object)],
236              
237             start_document_h
238             => [sub {
239             my($p) = @_;
240             $p->{first_chunk} = 0;
241             $p->{found} = {};
242             },
243             "self"],
244              
245             end_h
246             => [sub {
247             my($p,$tag) = @_;
248             $p->eof if $tag eq 'head'
249             },
250             "self,tagname"],
251              
252             start_h
253             => [sub {
254             my($p, $tag, $attr) = @_;
255             if ($tag eq 'meta' || $tag eq 'link') {
256             if ($tag eq 'link' && ($attr->{rel}||'') =~ m/\s/) {
257             # split
258             # into multiple s
259             push @{$p->{found}->{$tag}},
260             map { +{%{$attr}, rel => $_} }
261             split /\s+/,$attr->{rel};
262             }
263             else {
264             push @{$p->{found}->{$tag}}, $attr;
265             }
266             }
267             elsif ($tag ne 'head' && $tag ne 'html') {
268             # stop parsing
269             $p->eof;
270             }
271             },
272             "self,tagname,attr"],
273              
274             text_h
275             => [sub {
276             my($p, $text) = @_;
277             unless ($p->{first_chunk}) {
278             # drop Unicode BOM if found
279             if ($p->utf8_mode) {
280             $text =~ s/^\xEF\xBB\xBF//;
281             }
282             else {
283             $text =~ s/^\x{FEFF}//;
284             }
285             $p->{first_chunk}++;
286             }
287             # Normal text outside of an allowed tag
288             # means start of body
289             $p->eof if ($text =~ /\S/);
290             },
291             "self,text"],
292             );
293              
294             # XXX this line is also in HTML::HeadParser; do we need it?
295             # current theory is we don't because we're requiring at
296             # least version 3.40 which is already pretty ancient.
297             #
298             # *utf8_mode = sub { 1 } unless HTML::Entities::UNICODE_SUPPORT;
299              
300             our $_linkmeta_parser;
301              
302             # return { link => [links...], meta => [metas...] }
303             # where each link/meta is a hash of the attribute values
304             sub html_extract_linkmetas {
305             my $doc = shift;
306             $_linkmeta_parser ||= HTML::Parser->new(@_linkmeta_parser_options);
307             $_linkmeta_parser->parse($doc);
308             $_linkmeta_parser->eof;
309             return delete $_linkmeta_parser->{found};
310             }
311              
312             ### DEPRECATED, do not use, will be removed Real Soon Now
313             sub _extract_head_markup_only {
314             my $htmlref = shift;
315              
316             # kill all CDATA sections
317             $$htmlref =~ s///sg;
318              
319             # kill all comments
320             $$htmlref =~ s///sg;
321             # ***FIX?*** Strictly speaking, SGML comments must have matched
322             # pairs of '--'s but almost nobody checks for this or even knows
323              
324             # trim everything past the body. this is in case the user doesn't
325             # have a head document and somebody was able to inject their own
326             # head. -- brad choate
327             $$htmlref =~ s/
328             }
329              
330             1;