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