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