1package Net::OAuth::Message; 2use warnings; 3use strict; 4use base qw/Class::Data::Inheritable Class::Accessor/; 5use URI::Escape; 6use Net::OAuth; 7use URI; 8use URI::QueryParam; 9use Carp; 10 11use constant OAUTH_PREFIX => 'oauth_'; 12 13our $OAUTH_PREFIX_RE = do {my $p = OAUTH_PREFIX; qr/^$p/}; 14 15__PACKAGE__->mk_classdata(extension_param_patterns => []); 16 17sub add_required_message_params { 18 my $class = shift; 19 $class->required_message_params([@{$class->required_message_params}, @_]); 20 $class->all_message_params([@{$class->all_message_params}, @_]); 21 $class->all_params([@{$class->all_params}, @_]); 22 $class->mk_accessors(@_); 23} 24 25sub add_optional_message_params { 26 my $class = shift; 27 $class->optional_message_params([@{$class->optional_message_params}, @_]); 28 $class->all_message_params([@{$class->all_message_params}, @_]); 29 $class->all_params([@{$class->all_params}, @_]); 30 $class->mk_accessors(@_); 31} 32 33sub add_required_api_params { 34 my $class = shift; 35 $class->required_api_params([@{$class->required_api_params}, @_]); 36 $class->all_api_params([@{$class->all_api_params}, @_]); 37 $class->all_params([@{$class->all_params}, @_]); 38 $class->mk_accessors(@_); 39} 40 41sub add_extension_param_pattern { 42 my $class = shift; 43 $class->extension_param_patterns([@{$class->extension_param_patterns}, @_]); 44} 45 46sub add_to_signature { 47 my $class = shift; 48 $class->signature_elements([@{$class->signature_elements}, @_]); 49} 50 51sub new { 52 my $proto = shift; 53 my $class = ref $proto || $proto; 54 my %params = @_; 55 $class = get_versioned_class($class, \%params); 56 my $self = bless \%params, $class; 57 $self->set_defaults; 58 $self->check; 59 return $self; 60} 61 62sub get_versioned_class { 63 my $class = shift; 64 my $params = shift; 65 my $protocol_version = $params->{protocol_version} || $Net::OAuth::PROTOCOL_VERSION; 66 if (defined $protocol_version and $protocol_version == Net::OAuth::PROTOCOL_VERSION_1_0A and $class !~ /\::V1_0A\::/) { 67 (my $versioned_class = $class) =~ s/::(\w+)$/::V1_0A::$1/; 68 return $versioned_class if Net::OAuth::smart_require($versioned_class); 69 } 70 return $class; 71} 72 73sub set_defaults { 74 my $self = shift; 75 $self->{extra_params} ||= {}; 76 $self->{version} ||= Net::OAuth::OAUTH_VERSION unless $self->{from_hash}; 77} 78 79sub is_extension_param { 80 my $self = shift; 81 my $param = shift; 82 return grep ($param =~ $_, @{$self->extension_param_patterns}); 83} 84 85sub check { 86 my $self = shift; 87 foreach my $k (@{$self->required_message_params}, @{$self->required_api_params}) { 88 if (not defined $self->{$k}) { 89 croak "Missing required parameter '$k'"; 90 } 91 } 92 if ($self->{extra_params} and $self->allow_extra_params) { 93 foreach my $k (keys %{$self->{extra_params}}) { 94 if ($k =~ $OAUTH_PREFIX_RE) { 95 croak "Parameter '$k' not allowed in arbitrary params" 96 } 97 } 98 } 99} 100 101sub encode { 102 my $str = shift; 103 $str = "" unless defined $str; 104 unless($Net::OAuth::SKIP_UTF8_DOUBLE_ENCODE_CHECK) { 105 if ($str =~ /[\x80-\xFF]/ and !utf8::is_utf8($str)) { 106 warn "Net::OAuth warning: your OAuth message appears to contain some multi-byte characters that need to be decoded via Encode.pm or a PerlIO layer first. This may result in an incorrect signature."; 107 } 108 } 109 return URI::Escape::uri_escape_utf8($str,'^\w.~-'); 110} 111 112sub decode { 113 my $str = shift; 114 return uri_unescape($str); 115} 116 117sub allow_extra_params {1} 118 119sub sign_message {0} 120 121sub gather_message_parameters { 122 my $self = shift; 123 my %opts = @_; 124 $opts{quote} = "" unless defined $opts{quote}; 125 $opts{params} ||= []; 126 my %params; 127 foreach my $k (@{$self->required_message_params}, @{$self->optional_message_params}, @{$opts{add}}) { 128 next if $k eq 'signature' and (!$self->sign_message or !grep ($_ eq 'signature', @{$opts{add}})); 129 my $message_key = $self->is_extension_param($k) ? $k : OAUTH_PREFIX . $k; 130 my $v = $self->$k; 131 $params{$message_key} = $v if defined $v; 132 } 133 if ($self->{extra_params} and !$opts{no_extra} and $self->allow_extra_params) { 134 foreach my $k (keys %{$self->{extra_params}}) { 135 $params{$k} = $self->{extra_params}{$k}; 136 } 137 if ($self->can('request_url')) { 138 my $url = $self->request_url; 139 _ensure_uri_object($url); 140 foreach my $k ($url->query_param) { 141 $params{$k} = $url->query_param($k); 142 } 143 } 144 } 145 if ($opts{hash}) { 146 return \%params; 147 } 148 my @pairs; 149 while (my ($k,$v) = each %params) { 150 push @pairs, join('=', encode($k), $opts{quote} . encode($v) . $opts{quote}); 151 } 152 return sort(@pairs); 153} 154 155sub normalized_message_parameters { 156 my $self = shift; 157 return join('&', $self->gather_message_parameters); 158} 159 160sub signature_base_string { 161 my $self = shift; 162 return join('&', map(encode($self->$_), @{$self->signature_elements})); 163} 164 165sub sign { 166 my $self = shift; 167 my $class = $self->_signature_method_class; 168 $self->signature($class->sign($self, @_)); 169} 170 171sub verify { 172 my $self = shift; 173 my $class = $self->_signature_method_class; 174 return $class->verify($self, @_); 175} 176 177sub _signature_method_class { 178 my $self = shift; 179 (my $signature_method = $self->signature_method) =~ s/\W+/_/g; 180 my $sm_class = 'Net::OAuth::SignatureMethod::' . $signature_method; 181 croak "Unable to load $signature_method plugin" unless Net::OAuth::smart_require($sm_class); 182 return $sm_class; 183} 184 185sub to_authorization_header { 186 my $self = shift; 187 my $realm = shift; 188 my $sep = shift || ","; 189 if (defined $realm) { 190 $realm = "realm=\"$realm\"$sep"; 191 } 192 else { 193 $realm = ""; 194 } 195 return "OAuth $realm" . 196 join($sep, $self->gather_message_parameters(quote => '"', add => [qw/signature/], no_extra => 1)); 197} 198 199sub from_authorization_header { 200 my $proto = shift; 201 my $header = shift; 202 my $class = ref $proto || $proto; 203 croak "Header must start with \"OAuth \"" unless $header =~ s/OAuth //; 204 my @header = split /[\s]*,[\s]*/, $header; 205 shift @header if $header[0] =~ /^realm=/i; 206 return $class->_from_pairs(\@header, @_) 207} 208 209sub _from_pairs() { 210 my $class = shift; 211 my $pairs = shift; 212 if (ref $pairs ne 'ARRAY') { 213 croak 'Expected an array!'; 214 } 215 my %params; 216 foreach my $pair (@$pairs) { 217 my ($k,$v) = split /=/, $pair; 218 if (defined $k and defined $v) { 219 $v =~ s/(^"|"$)//g; 220 ($k,$v) = map decode($_), $k, $v; 221 $params{$k} = $v; 222 } 223 } 224 return $class->from_hash(\%params, @_); 225} 226 227sub from_hash { 228 my $proto = shift; 229 my $class = ref $proto || $proto; 230 my $hash = shift; 231 if (ref $hash ne 'HASH') { 232 croak 'Expected a hash!'; 233 } 234 my %api_params = @_; 235 # need to do this earlier than Message->new because 236 # the below validation step needs the correct class. 237 # https://rt.cpan.org/Public/Bug/Display.html?id=47293 238 $class = get_versioned_class($class, \%api_params); 239 my %msg_params; 240 foreach my $k (keys %$hash) { 241 if ($k =~ s/$OAUTH_PREFIX_RE//) { 242 if (!grep ($_ eq $k, @{$class->all_message_params})) { 243 croak "Parameter ". OAUTH_PREFIX ."$k not valid for a message of type $class"; 244 } 245 else { 246 $msg_params{$k} = $hash->{OAUTH_PREFIX . $k}; 247 } 248 } 249 elsif ($class->is_extension_param($k)) { 250 if (!grep ($_ eq $k, @{$class->all_message_params})) { 251 croak "Parameter $k not valid for a message of type $class"; 252 } 253 else { 254 $msg_params{$k} = $hash->{$k}; 255 } 256 } 257 else { 258 $msg_params{extra_params}->{$k} = $hash->{$k}; 259 } 260 } 261 $api_params{from_hash} = 1; 262 return $class->new(%msg_params, %api_params); 263} 264 265sub _ensure_uri_object { 266 $_[0] = UNIVERSAL::isa($_[0], 'URI') ? $_[0] : URI->new($_[0]); 267} 268 269sub from_url { 270 my $proto = shift; 271 my $class = ref $proto || $proto; 272 my $url = shift; 273 _ensure_uri_object($url); 274 return $class->from_hash($url->query_form_hash, @_); 275} 276 277sub to_post_body { 278 my $self = shift; 279 return join('&', $self->gather_message_parameters(add => [qw/signature/])); 280} 281 282sub from_post_body { 283 my $proto = shift; 284 my $class = ref $proto || $proto; 285 my @pairs = split '&', shift; 286 return $class->_from_pairs(\@pairs, @_); 287} 288 289sub to_hash { 290 my $self = shift; 291 return $self->gather_message_parameters(hash => 1, add => [qw/signature/]); 292} 293 294sub to_url { 295 my $self = shift; 296 my $url = shift; 297 if (!defined $url and $self->can('request_url') and defined $self->request_url) { 298 $url = $self->request_url; 299 } 300 if (defined $url) { 301 _ensure_uri_object($url); 302 $url = $url->clone; # don't modify the URL that was passed in 303 $url->query(undef); # remove any existing query params, as these may cause the signature to break 304 my $params = $self->to_hash; 305 my $sep = '?'; 306 foreach my $k (sort keys %$params) { 307 $url .= $sep . encode($k) . '=' . encode( $params->{$k} ); 308 $sep = '&' if $sep eq '?'; 309 } 310 return $url; 311 } 312 else { 313 return $self->to_post_body; 314 } 315} 316 317=head1 NAME 318 319Net::OAuth::Message - base class for OAuth messages 320 321=head1 SEE ALSO 322 323L<Net::OAuth>, L<http://oauth.net> 324 325=head1 AUTHOR 326 327Keith Grennan, C<< <kgrennan at cpan.org> >> 328 329=head1 COPYRIGHT & LICENSE 330 331Copyright 2007 Keith Grennan, all rights reserved. 332 333This program is free software; you can redistribute it and/or modify it 334under the same terms as Perl itself. 335 336=cut 337 3381; 339