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