File Coverage

blib/lib/Net/OpenID/IndirectMessage.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1              
2             package Net::OpenID::IndirectMessage;
3             {
4             $Net::OpenID::IndirectMessage::VERSION = '1.18';
5             }
6              
7 2     2   65771 use strict;
  2         5  
  2         93  
8 2     2   13 use Carp;
  2         4  
  2         234  
9 2     2   3353 use Net::OpenID::Common;
  0            
  0            
10              
11             sub new {
12             my $class = shift;
13             my $what = shift;
14             my %opts = @_;
15              
16             my $self = bless {}, $class;
17              
18             $self->{minimum_version} = delete $opts{minimum_version};
19              
20             Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
21              
22             my $getter;
23             my $enumer;
24             if (ref $what eq "HASH") {
25             # In this case it's the caller's responsibility to determine
26             # whether the method is GET or POST.
27             $getter = sub { $what->{$_[0]}; };
28             $enumer = sub { keys(%$what); };
29             }
30             elsif (ref $what eq "Apache") {
31             my %get;
32             if ($what->method eq 'POST') {
33             %get = $what->content;
34             }
35             else {
36             %get = $what->args;
37             }
38             $getter = sub { $get{$_[0]}; };
39             $enumer = sub { keys(%get); };
40             }
41             elsif (ref $what eq "Plack::Request") {
42             my $p = $what->method eq 'POST' ? $what->body_parameters : $what->query_parameters;
43             $getter = sub { $p->get($_[0]); };
44             $enumer = sub { keys %{$p}; };
45             }
46             elsif (ref $what ne "CODE") {
47             # assume an object that follows the CGI interface and has a param() method
48             # CGI does the right thing and omits query parameters if this is a POST
49             # others (Apache::Request, Apache2::Request) mix query and body params.
50             $getter = sub { scalar $what->param($_[0]); };
51             $enumer = sub { $what->param; };
52             }
53              
54             else {
55             # CODE reference
56             my @keys = ();
57             my $enumerated;
58             $getter = $what;
59             $enumer = sub {
60             unless ($enumerated) {
61             $enumerated = 1;
62             # In Consumer/Common 1.03 and predecessors, coderefs
63             # did not have to be able to enumerate all keys.
64             # Therefore, we must cope with legacy coderefs being
65             # passed in which don't expect to be called with no
66             # arguments, and then, most likely, fail in one of
67             # three ways:
68             # (1) return empty list
69             # (2) retrieve undef/'' value for undef/'' key.
70             # (3) raise an error
71             # We normalize these all to empty list, which our
72             # caller can then recognize as obviously wrong
73             # and do something about it.
74             eval { @keys = $what->() };
75             @keys = ()
76             if (@keys == 1 &&
77             !(defined($keys[0]) && length($keys[0])));
78             }
79             return @keys;
80             }
81             }
82             $self->{getter} = $getter;
83             $self->{enumer} = $enumer;
84              
85             # Now some quick pre-configuration of a few bits
86              
87             # Is this an OpenID message at all?
88             # All OpenID messages have an openid.mode value...
89             return undef unless $self->get('mode');
90              
91             # Is this an OpenID 2.0 message?
92             my $ns = $self->get('ns');
93              
94              
95             # The 2.0 spec section 4.1.2 requires that we support these namespace values
96             # but act like it's a normal 1.1 request.
97             # We do this by just pretending that ns wasn't set at all.
98             if ($ns && ($ns eq 'http://openid.net/signon/1.1' || $ns eq 'http://openid.net/signon/1.0')) {
99             $ns = undef;
100             }
101              
102             if (defined($ns) && $ns eq OpenID::util::version_2_namespace()) {
103             $self->{protocol_version} = 2;
104             }
105             elsif (! defined($ns)) {
106             # No namespace at all means a 1.1 message
107             if (($self->{minimum_version}||0) <= 1) {
108             $self->{protocol_version} = 1;
109             }
110             else {
111             # Pretend we don't understand the message.
112             return undef;
113             }
114             }
115             else {
116             # Unknown version is the same as not being an OpenID message at all
117             return undef;
118             }
119              
120             # This will be populated in on demand
121             $self->{extension_prefixes} = undef;
122              
123             return $self;
124             }
125              
126             sub protocol_version {
127             return $_[0]->{protocol_version};
128             }
129              
130             sub mode {
131             my $self = shift;
132             return $self->get('mode');
133             }
134              
135             sub get {
136             my $self = shift;
137             my $key = shift or Carp::croak("No argument name supplied to get method");
138              
139             # Arguments can only contain letters, numbers, underscores and dashes
140             Carp::croak("Invalid argument key $key") unless $key =~ /^[\w\-]+$/;
141             Carp::croak("Too many arguments") if scalar(@_);
142              
143             return $self->{getter}->("openid.$key");
144             }
145              
146             sub raw_get {
147             my $self = shift;
148             my $key = shift or Carp::croak("No argument name supplied to raw_get method");
149              
150             return $self->{getter}->($key);
151             }
152              
153             sub getter {
154             my $self = shift;
155              
156             return $self->{getter};
157             }
158              
159             # NOTE RE all_parameters():
160             #
161             # It was originally thought that enumeration of URL parameters was
162             # unnecessary except to support extensions, i.e., that support of the
163             # core protocol did not need it. While this is true in OpenID 1.1, it
164             # is not the case in OpenID 2.0 where check_authentication requires
165             # sending back a complete copy of the positive assertion message
166             # that was received indirectly.
167             #
168             # In cases where legacy client code is not supplying a real enumerator,
169             # this routine will return an empty list and callers will need to
170             # check for this. Recall that actual messages in all versions of the
171             # Openid protocol (thus far) are guaranteed to have at least an
172             # 'openid.mode' parameter.
173              
174             sub all_parameters {
175             my $self = shift;
176              
177             return $self->{enumer}->();
178             }
179              
180             sub get_ext {
181             my $self = shift;
182             my $namespace = shift or Carp::croak("No namespace URI supplied to get_ext method");
183             my $key = shift;
184              
185             Carp::croak("Too many arguments") if scalar(@_);
186              
187             $self->_compute_extension_prefixes() unless defined($self->{extension_prefixes});
188              
189             my $alias = $self->{extension_prefixes}{$namespace};
190             return $key ? undef : {} unless $alias;
191              
192             if ($key) {
193             return $self->{getter}->("openid.$alias.$key");
194             }
195             else {
196             my $prefix = "openid.$alias.";
197             my $prefixlen = length($prefix);
198             my $ret = {};
199             foreach my $key ($self->all_parameters) {
200             next unless substr($key, 0, $prefixlen) eq $prefix;
201             $ret->{substr($key, $prefixlen)} = $self->{getter}->($key);
202             }
203             return $ret;
204             }
205             }
206              
207             sub has_ext {
208             my $self = shift;
209             my $namespace = shift or Carp::croak("No namespace URI supplied to get_ext method");
210              
211             Carp::croak("Too many arguments") if scalar(@_);
212              
213             $self->_compute_extension_prefixes() unless defined($self->{extension_prefixes});
214              
215             return defined($self->{extension_prefixes}{$namespace}) ? 1 : 0;
216             }
217              
218             sub _compute_extension_prefixes {
219             my ($self) = @_;
220              
221             # return unless $self->{enumer};
222              
223             $self->{extension_prefixes} = {};
224             if ($self->protocol_version != 1) {
225             foreach my $key ($self->all_parameters) {
226             next unless $key =~ /^openid\.ns\.(\w+)$/;
227             my $alias = $1;
228             my $uri = $self->{getter}->($key);
229             $self->{extension_prefixes}{$uri} = $alias;
230             }
231             }
232             else {
233             # Synthesize the SREG namespace as it was used in OpenID 1.1
234             $self->{extension_prefixes}{"http://openid.net/extensions/sreg/1.1"} = "sreg";
235             }
236             }
237              
238             1;
239              
240             =head1 NAME
241              
242             Net::OpenID::IndirectMessage - Class representing a collection of namespaced arguments
243              
244             =head1 VERSION
245              
246             version 1.18
247              
248             =head1 DESCRIPTION
249              
250             This class acts as an abstraction layer over a collection of flat URL arguments
251             which supports namespaces as defined by the OpenID Auth 2.0 specification.
252              
253             It also recognises when it is given OpenID 1.1 non-namespaced arguments and
254             acts as if the relevant namespaces were present. In this case, it only
255             supports the basic OpenID 1.1 arguments and the extension arguments
256             for Simple Registration.
257              
258             This class can operate on
259             a normal hashref,
260             a L object or any object with a C method that behaves similarly
261             (L, L, L,...),
262             an L object,
263             a L object, or
264             an arbitrary C ref that when given a key name as its first parameter
265             and returns a value and if given no arguments returns a list of all keys present.
266              
267             If you pass in a hashref or a coderef it is your responsibility as the caller
268             to check the HTTP request method and pass in the correct set of arguments.
269             For the other kinds of objects, this module will do the right thing automatically.
270              
271             =head1 SYNOPSIS
272              
273             use Net::OpenID::IndirectMessage;
274              
275             # Pass in something suitable for the underlying flat dictionary.
276             # Will return an instance if the request arguments can be understood
277             # as a supported OpenID Message format.
278             # Will return undef if this doesn't seem to be an OpenID Auth message.
279             # Will croak if the $argumenty_thing is not of a suitable type.
280             my $args = Net::OpenID::IndirectMessage->new($argumenty_thing);
281              
282             # Determine which protocol version the message is using.
283             # Currently this can be either 1 for 1.1 or 2 for 2.0.
284             # Expect larger numbers for other versions in future.
285             # Most callers don't really need to care about this.
286             my $version = $args->protocol_version();
287              
288             # Get a core argument value ("openid.mode")
289             my $mode = $args->get("mode");
290              
291             # Get an extension argument value
292             my $nickname = $args->get_ext("http://openid.net/extensions/sreg/1.1", "nickname");
293              
294             # Get hashref of all arguments in a given namespace
295             my $sreg = $args->get_ext("http://openid.net/extensions/sreg/1.1");
296              
297             Most of the time callers won't need to use this class directly, but will instead
298             access it through a L instance.
299              
300             =head1 METHODS
301              
302             =over 4
303              
304             =item B
305              
306             Currently returns 1 or 2, according as this is an OpenID 1.0/1.1 or an OpenID 2.0 message.
307              
308             =item B
309              
310             Takes an extension namespace and returns true if the named extension is used in this message.
311              
312             =item B
313              
314             Takes an extension namespace and an optional parameter name, returns the parameter value,
315             or if no parameter given, the parameter value.
316              
317             =back