, and I; the exact value
155 | is
156 |
157 | g ^ priv_key mod p
158 |
159 | The parties exchange these public keys.
160 |
161 | The shared secret key is generated based on the exchanged public
162 | key, the private key, and I
. If the public key of Party B is
163 | denoted I, then the shared secret is equal to
164 |
165 | pub_key_B ^ priv_key mod p
166 |
167 | The mathematical principles involved insure that both parties will
168 | generate the same shared secret key.
169 |
170 | More information can be found in PKCS #3 (Diffie-Hellman Key
171 | Agreement Standard):
172 |
173 | http://www.rsasecurity.com/rsalabs/pkcs/pkcs-3/
174 |
175 | =head1 USAGE
176 |
177 | I implements the core routines needed to use
178 | Diffie-Hellman key exchange. To actually use the algorithm,
179 | you'll need to start with values for I and I; I is a
180 | large prime, and I is a base which must be larger than 0
181 | and less than I.
182 |
183 | I uses I internally for big-integer
184 | calculations. All accessor methods (I, I, I, and
185 | I) thus return I objects, as does the
186 | I method. The accessors, however, allow setting with a
187 | scalar decimal string, hex string (^0x), Math::BigInt object, or
188 | Math::Pari object (for backwards compatibility).
189 |
190 | =head2 $dh = Crypt::DH->new([ %param ]).
191 |
192 | Constructs a new I object and returns the object.
193 | I<%param> may include none, some, or all of the keys I, I, and
194 | I.
195 |
196 | =head2 $dh->p([ $p ])
197 |
198 | Given an argument I<$p>, sets the I parameter (large prime) for
199 | this I object.
200 |
201 | Returns the current value of I. (as a Math::BigInt object)
202 |
203 | =head2 $dh->g([ $g ])
204 |
205 | Given an argument I<$g>, sets the I parameter (base) for
206 | this I object.
207 |
208 | Returns the current value of I.
209 |
210 | =head2 $dh->generate_keys
211 |
212 | Generates the public and private key portions of the I
213 | object, assuming that you've already filled I and I with
214 | appropriate values.
215 |
216 | If you've provided a priv_key, it's used, otherwise a random priv_key
217 | is created using either Crypt::Random (if already loaded), or
218 | /dev/urandom, or Perl's rand, in that order.
219 |
220 | =head2 $dh->compute_secret( $public_key )
221 |
222 | Given the public key I<$public_key> of Party B (the party with which
223 | you're performing key negotiation and exchange), computes the shared
224 | secret key, based on that public key, your own private key, and your
225 | own large prime value (I).
226 |
227 | The historical method name "compute_key" is aliased to this for
228 | compatibility.
229 |
230 | =head2 $dh->priv_key([ $priv_key ])
231 |
232 | Returns the private key. Given an argument I<$priv_key>, sets the
233 | I parameter for this I object.
234 |
235 | =head2 $dh->pub_key
236 |
237 | Returns the public key.
238 |
239 | =head1 AUTHOR & COPYRIGHT
240 |
241 | Benjamin Trott, ben@rhumba.pair.com
242 |
243 | Brad Fitzpatrick, brad@danga.com
244 |
245 | Except where otherwise noted, Crypt::DH is Copyright 2001
246 | Benjamin Trott. All rights reserved. Crypt::DH is free
247 | software; you may redistribute it and/or modify it under
248 | the same terms as Perl itself.
249 |
250 | =cut
251 |
--------------------------------------------------------------------------------
/cgi/Net/OpenID/Association.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 | use Carp ();
3 |
4 | ############################################################################
5 | package Net::OpenID::Association;
6 | use fields (
7 | 'server', # author-identity identity server endpoint
8 | 'secret', # the secret for this association
9 | 'handle', # the 255-character-max ASCII printable handle (33-126)
10 | 'expiry', # unixtime, adjusted, of when this association expires
11 | 'type', # association type
12 | );
13 |
14 | use Storable ();
15 | use Digest::SHA1 qw(sha1);
16 |
17 | sub new {
18 | my Net::OpenID::Association $self = shift;
19 | $self = fields::new( $self ) unless ref $self;
20 | my %opts = @_;
21 | for my $f (qw( server secret handle expiry type )) {
22 | $self->{$f} = delete $opts{$f};
23 | }
24 | Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
25 | return $self;
26 | }
27 |
28 | sub handle {
29 | my $self = shift;
30 | die if @_;
31 | $self->{'handle'};
32 | }
33 |
34 | sub secret {
35 | my $self = shift;
36 | die if @_;
37 | $self->{'secret'};
38 | }
39 |
40 | sub type {
41 | my $self = shift;
42 | die if @_;
43 | $self->{'type'};
44 | }
45 |
46 | sub server {
47 | my Net::OpenID::Association $self = shift;
48 | Carp::croak("Too many parameters") if @_;
49 | return $self->{server};
50 | }
51 |
52 | sub expired {
53 | my Net::OpenID::Association $self = shift;
54 | return time() > $self->{'expiry'};
55 | }
56 |
57 | sub usable {
58 | my Net::OpenID::Association $self = shift;
59 | return 0 unless $self->{'handle'} =~ /^[\x21-\x7e]{1,255}$/;
60 | return 0 unless $self->{'expiry'} =~ /^\d+$/;
61 | return 0 unless $self->{'secret'};
62 | return 0 if $self->expired;
63 | return 1;
64 | }
65 |
66 |
67 | # return a handle for an identity server, or undef if
68 | # no local storage/cache is available, in which case the caller
69 | # goes into dumb consumer mode. will do a POST and allocate
70 | # a new assoc_handle if none is found, or has expired
71 | sub server_assoc {
72 | my ($csr, $server, $force_reassociate, %opts) = @_;
73 |
74 | my $protocol_version = delete $opts{protocol_version} || 1;
75 | Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
76 |
77 | # closure to return undef (dumb consumer mode) and log why
78 | my $dumb = sub {
79 | $csr->_debug("server_assoc: dumb mode: $_[0]");
80 | return undef;
81 | };
82 |
83 | my $cache = $csr->cache;
84 | return $dumb->("no_cache") unless $cache;
85 |
86 | unless ($force_reassociate) {
87 | # try first from cached association handle
88 | if (my $handle = $cache->get("shandle:$server")) {
89 | my $assoc = handle_assoc($csr, $server, $handle);
90 |
91 | if ($assoc && $assoc->usable) {
92 | $csr->_debug("Found association from cache (handle=$handle)");
93 | return $assoc;
94 | }
95 | }
96 | }
97 |
98 | # make a new association
99 | my $dh = _default_dh();
100 |
101 | my %post = (
102 | "openid.mode" => "associate",
103 | "openid.assoc_type" => "HMAC-SHA1",
104 | "openid.session_type" => "DH-SHA1",
105 | "openid.dh_consumer_public" => OpenID::util::bi2arg($dh->pub_key),
106 | );
107 |
108 | if ($protocol_version == 2) {
109 | $post{"openid.ns"} = OpenID::util::version_2_namespace();
110 | }
111 |
112 | my $req = HTTP::Request->new(POST => $server);
113 | $req->header("Content-Type" => "application/x-www-form-urlencoded");
114 | $req->content(join("&", map { "$_=" . OpenID::util::eurl($post{$_}) } keys %post));
115 |
116 | $csr->_debug("Associate mode request: " . $req->content);
117 |
118 | my $ua = $csr->ua;
119 | my $res = $ua->request($req);
120 |
121 | # uh, some failure, let's go into dumb mode?
122 | return $dumb->("http_failure_no_associate") unless $res && $res->is_success;
123 |
124 | my $recv_time = time();
125 | my $content = $res->content;
126 | my %args = OpenID::util::parse_keyvalue($content);
127 | $csr->_debug("Response to associate mode: [$content] parsed = " . join(",", %args));
128 |
129 | return $dumb->("unknown_assoc_type") unless $args{'assoc_type'} eq "HMAC-SHA1";
130 |
131 | my $stype = $args{'session_type'};
132 | return $dumb->("unknown_session_type") if $stype && $stype ne "DH-SHA1";
133 |
134 | # protocol version 1.1
135 | my $expires_in = $args{'expires_in'};
136 |
137 | # protocol version 1.0 (DEPRECATED)
138 | if (! $expires_in) {
139 | if (my $issued = OpenID::util::w3c_to_time($args{'issued'})) {
140 | my $expiry = OpenID::util::w3c_to_time($args{'expiry'});
141 | my $replace_after = OpenID::util::w3c_to_time($args{'replace_after'});
142 |
143 | # seconds ahead (positive) or behind (negative) the server is
144 | $expires_in = ($replace_after || $expiry) - $issued;
145 | }
146 | }
147 |
148 | # between 1 second and 2 years
149 | return $dumb->("bogus_expires_in") unless $expires_in > 0 && $expires_in < 63072000;
150 |
151 | my $ahandle = $args{'assoc_handle'};
152 |
153 | my $secret;
154 | if ($stype ne "DH-SHA1") {
155 | $secret = OpenID::util::d64($args{'mac_key'});
156 | } else {
157 | my $server_pub = OpenID::util::arg2bi($args{'dh_server_public'});
158 | my $dh_sec = $dh->compute_secret($server_pub);
159 | $secret = OpenID::util::d64($args{'enc_mac_key'}) ^ sha1(OpenID::util::bi2bytes($dh_sec));
160 | }
161 | return $dumb->("secret_not_20_bytes") unless length($secret) == 20;
162 |
163 | my %assoc = (
164 | handle => $ahandle,
165 | server => $server,
166 | secret => $secret,
167 | type => $args{'assoc_type'},
168 | expiry => $recv_time + $expires_in,
169 | );
170 |
171 | my $assoc = Net::OpenID::Association->new( %assoc );
172 | return $dumb->("assoc_undef") unless $assoc;
173 |
174 | $cache->set("hassoc:$server:$ahandle", Storable::freeze(\%assoc));
175 | $cache->set("shandle:$server", $ahandle);
176 |
177 | # now we test that the cache object given to us actually works. if it
178 | # doesn't, it'll also fail later, making the verify fail, so let's
179 | # go into stateless (dumb mode) earlier if we can detect this.
180 | $cache->get("shandle:$server")
181 | or return $dumb->("cache_broken");
182 |
183 | return $assoc;
184 | }
185 |
186 | # returns association, or undef if it can't be found
187 | sub handle_assoc {
188 | my ($csr, $server, $handle) = @_;
189 |
190 | # closure to return undef (dumb consumer mode) and log why
191 | my $dumb = sub {
192 | $csr->_debug("handle_assoc: dumb mode: $_[0]");
193 | return undef;
194 | };
195 |
196 | return $dumb->("no_handle") unless $handle;
197 |
198 | my $cache = $csr->cache;
199 | return $dumb->("no_cache") unless $cache;
200 |
201 | my $frozen = $cache->get("hassoc:$server:$handle");
202 | return $dumb->("not_in_cache") unless $frozen;
203 |
204 | my $param = eval { Storable::thaw($frozen) };
205 | return $dumb->("not_a_hashref") unless ref $param eq "HASH";
206 |
207 | return Net::OpenID::Association->new( %$param );
208 | }
209 |
210 | sub invalidate_handle {
211 | my ($csr, $server, $handle) = @_;
212 | my $cache = $csr->cache
213 | or return;
214 | $cache->set("hassoc:$server:$handle", "");
215 | }
216 |
217 | sub _default_dh {
218 | my $dh = Crypt::DH->new;
219 | $dh->p("155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443");
220 | $dh->g("2");
221 | $dh->generate_keys;
222 | return $dh;
223 | }
224 |
225 |
226 |
227 | 1;
228 |
229 | __END__
230 |
231 | =head1 NAME
232 |
233 | Net::OpenID::Association - a relationship with an identity server
234 |
235 | =head1 DESCRIPTION
236 |
237 | Internal class.
238 |
239 | =head1 COPYRIGHT, WARRANTY, AUTHOR
240 |
241 | See L for author, copyrignt and licensing information.
242 |
243 | =head1 SEE ALSO
244 |
245 | L
246 |
247 | L
248 |
249 | L
250 |
251 | Website: L
252 |
253 |
--------------------------------------------------------------------------------
/cgi/Net/OpenID/IndirectMessage.pm:
--------------------------------------------------------------------------------
1 |
2 | package Net::OpenID::IndirectMessage;
3 |
4 | use strict;
5 | use Carp;
6 | use Net::OpenID::Consumer;
7 |
8 | sub new {
9 | my $class = shift;
10 | my $what = shift;
11 | my %opts = @_;
12 |
13 | my $self = bless {}, $class;
14 |
15 | $self->{minimum_version} = delete $opts{minimum_version};
16 |
17 | Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
18 |
19 | my $getter;
20 | my $enumer;
21 | if (ref $what eq "HASH") {
22 | # In this case it's the caller's responsibility to determine
23 | # whether the method is GET or POST.
24 | $getter = sub { $what->{$_[0]}; };
25 | $enumer = sub { keys(%$what); };
26 | }
27 | elsif (UNIVERSAL::isa($what, "CGI")) {
28 | # CGI automatically does what we need when method is POST
29 | $getter = sub { scalar $what->param($_[0]); };
30 | $enumer = sub { $what->param; };
31 | }
32 | elsif (ref $what eq "Apache") {
33 | my %get;
34 | if ($what->method eq 'POST') {
35 | %get = $what->content;
36 | }
37 | else {
38 | %get = $what->args;
39 | }
40 | $getter = sub { $get{$_[0]}; };
41 | $enumer = sub { keys(%get); };
42 | }
43 | elsif (ref $what eq "Apache::Request") {
44 | # Apache::Request includes the POST and GET arguments in ->param
45 | # when doing a POST request, which is close enough to what
46 | # the spec requires.
47 | $getter = sub { scalar $what->param($_[0]); };
48 | $enumer = sub { $what->param; };
49 | }
50 | elsif (ref $what eq "CODE") {
51 | $getter = $what;
52 | # We can't enumerate with just a coderef.
53 | # OpenID 2 spec only requires enumeration to support
54 | # extension namespaces, so we don't care too much.
55 | $enumer = sub { return (); };
56 | }
57 | else {
58 | $what = 'undef' if !defined $what;
59 | Carp::croak("Unknown parameter type ($what)");
60 | }
61 | $self->{getter} = $getter;
62 | $self->{enumer} = $enumer;
63 |
64 | # Now some quick pre-configuration of a few bits
65 |
66 | # Is this an OpenID message at all?
67 | # All OpenID messages have an openid.mode value...
68 | return undef unless $self->get('mode');
69 |
70 | # Is this an OpenID 2.0 message?
71 | my $ns = $self->get('ns');
72 |
73 |
74 | # The 2.0 spec section 4.1.2 requires that we support these namespace values
75 | # but act like it's a normal 1.1 request.
76 | # We do this by just pretending that ns wasn't set at all.
77 | if ($ns && ($ns eq 'http://openid.net/signon/1.1' || $ns eq 'http://openid.net/signon/1.0')) {
78 | $ns = undef;
79 | }
80 |
81 | if (defined($ns) && $ns eq OpenID::util::version_2_namespace()) {
82 | $self->{protocol_version} = 2;
83 | }
84 | elsif (! defined($ns)) {
85 | # No namespace at all means a 1.1 message
86 | if (($self->{minimum_version}||0) <= 1) {
87 | $self->{protocol_version} = 1;
88 | }
89 | else {
90 | # Pretend we don't understand the message.
91 | return undef;
92 | }
93 | }
94 | else {
95 | # Unknown version is the same as not being an OpenID message at all
96 | return undef;
97 | }
98 |
99 | # This will be populated in on demand
100 | $self->{extension_prefixes} = undef;
101 |
102 | return $self;
103 | }
104 |
105 | sub protocol_version {
106 | return $_[0]->{protocol_version};
107 | }
108 |
109 | sub mode {
110 | my $self = shift;
111 | return $self->get('mode');
112 | }
113 |
114 | sub get {
115 | my $self = shift;
116 | my $key = shift or Carp::croak("No argument name supplied to get method");
117 |
118 | # NOTE: There is intentionally no way to get all of the keys in the core
119 | # namespace because that means we don't need to be able to enumerate
120 | # to support the core protocol, and there is no requirement to enumerate
121 | # anyway.
122 |
123 | # Arguments can only contain letters, numbers, underscores and dashes
124 | Carp::croak("Invalid argument key $key") unless $key =~ /^[\w\-]+$/;
125 | Carp::croak("Too many arguments") if scalar(@_);
126 |
127 | return $self->{getter}->("openid.$key");
128 | }
129 |
130 | sub raw_get {
131 | my $self = shift;
132 | my $key = shift or Carp::croak("No argument name supplied to raw_get method");
133 |
134 | return $self->{getter}->($key);
135 | }
136 |
137 | sub getter {
138 | my $self = shift;
139 |
140 | return $self->{getter};
141 | }
142 |
143 | sub get_ext {
144 | my $self = shift;
145 | my $namespace = shift or Carp::croak("No namespace URI supplied to get_ext method");
146 | my $key = shift;
147 |
148 | Carp::croak("Too many arguments") if scalar(@_);
149 |
150 | $self->_compute_extension_prefixes() unless defined($self->{extension_prefixes});
151 |
152 | my $alias = $self->{extension_prefixes}{$namespace};
153 | return $key ? undef : {} unless $alias;
154 |
155 | if ($key) {
156 | return $self->{getter}->("openid.$alias.$key");
157 | }
158 | else {
159 | my $prefix = "openid.$alias.";
160 | my $prefixlen = length($prefix);
161 | my $ret = {};
162 | foreach my $key ($self->{enumer}->()) {
163 | next unless substr($key, 0, $prefixlen) eq $prefix;
164 | $ret->{substr($key, $prefixlen)} = $self->{getter}->($key);
165 | }
166 | return $ret;
167 | }
168 | }
169 |
170 | sub has_ext {
171 | my $self = shift;
172 | my $namespace = shift or Carp::croak("No namespace URI supplied to get_ext method");
173 |
174 | Carp::croak("Too many arguments") if scalar(@_);
175 |
176 | $self->_compute_extension_prefixes() unless defined($self->{extension_prefixes});
177 |
178 | return defined($self->{extension_prefixes}{$namespace}) ? 1 : 0;
179 | }
180 |
181 | sub _compute_extension_prefixes {
182 | my ($self) = @_;
183 |
184 | return unless $self->{enumer};
185 |
186 | $self->{extension_prefixes} = {};
187 | if ($self->protocol_version != 1) {
188 | foreach my $key ($self->{enumer}->()) {
189 | next unless $key =~ /^openid\.ns\.(\w+)$/;
190 | my $alias = $1;
191 | my $uri = $self->{getter}->($key);
192 | $self->{extension_prefixes}{$uri} = $alias;
193 | }
194 | }
195 | else {
196 | # Synthesize the SREG namespace as it was used in OpenID 1.1
197 | $self->{extension_prefixes}{"http://openid.net/extensions/sreg/1.1"} = "sreg";
198 | }
199 | }
200 |
201 | 1;
202 |
203 | =head1 NAME
204 |
205 | Net::OpenID::IndirectMessage - Class representing a collection of namespaced arguments
206 |
207 | =head1 DESCRIPTION
208 |
209 | This class acts as an abstraction layer over a collection of flat URL arguments
210 | which supports namespaces as defined by the OpenID Auth 2.0 specification.
211 |
212 | It also recognises when its is given OpenID 1.1 non-namespaced arguments and
213 | acts as if the relevant namespaces were present. In this case, it only
214 | supports the basic OpenID 1.1 arguments and the extension arguments
215 | for Simple Registration.
216 |
217 | This class can operate on a normal hashref, a L object, an L
218 | object, an L object or an arbitrary C ref that takes
219 | a key name as its first parameter and returns a value. However,
220 | if you use a coderef then extension arguments are not supported.
221 |
222 | If you pass in a hashref or a coderef it is your responsibility as the caller
223 | to check the HTTP request method and pass in the correct set of arguments. If
224 | you use an Apache, Apache::Request or CGI object then this module will do
225 | the right thing automatically.
226 |
227 | =head1 SYNOPSIS
228 |
229 | use Net::OpenID::IndirectMessage;
230 |
231 | # Pass in something suitable for the underlying flat dictionary.
232 | # Will return an instance if the request arguments can be understood
233 | # as a supported OpenID Message format.
234 | # Will return undef if this doesn't seem to be an OpenID Auth message.
235 | # Will croak if the $argumenty_thing is not of a suitable type.
236 | my $args = Net::OpenID::IndirectMessage->new($argumenty_thing);
237 |
238 | # Determine which protocol version the message is using.
239 | # Currently this can be either 1 for 1.1 or 2 for 2.0.
240 | # Expect larger numbers for other versions in future.
241 | # Most callers don't really need to care about this.
242 | my $version = $args->protocol_version();
243 |
244 | # Get a core argument value ("openid.mode")
245 | my $mode = $args->get("mode");
246 |
247 | # Get an extension argument value
248 | my $nickname = $args->get_ext("http://openid.net/extensions/sreg/1.1", "nickname");
249 |
250 | # Get hashref of all arguments in a given namespace
251 | my $sreg = $args->get_ext("http://openid.net/extensions/sreg/1.1");
252 |
253 | Most of the time callers won't need to use this class directly, but will instead
254 | access it through a L instance.
255 |
256 |
--------------------------------------------------------------------------------
/cgi/Lingua/Stem/EnBroken.pm:
--------------------------------------------------------------------------------
1 | package Lingua::Stem::EnBroken;
2 |
3 | # $RCSfile: En.pm,v $ $Revision: 1.4 $ $Date: 1999/06/24 23:33:37 $ $Author: snowhare $
4 |
5 | =head1 NAME
6 |
7 | Lingua::Stem::EnBroken - Porter's stemming algorithm for 'generic' English
8 |
9 | =head1 SYNOPSIS
10 |
11 | use Lingua::Stem::EnBroken;
12 | my $stems = Lingua::Stem::EnBroken::stem({ -words => $word_list_reference,
13 | -locale => 'en',
14 | -exceptions => $exceptions_hash,
15 | });
16 |
17 | =head1 DESCRIPTION
18 |
19 | This routine MIS-applies the Porter Stemming Algorithm to its parameters,
20 | returning the stemmed words. It is an intentionally broken version
21 | of Lingua::Stem::En for people needing backwards compatibility with
22 | Lingua::Stem 0.30 and Lingua::Stem 0.40. Do not use it if you aren't
23 | one of those people.
24 |
25 | It is derived from the C program "stemmer.c"
26 | as found in freewais and elsewhere, which contains these notes:
27 |
28 | Purpose: Implementation of the Porter stemming algorithm documented
29 | in: Porter, M.F., "An Algorithm For Suffix Stripping,"
30 | Program 14 (3), July 1980, pp. 130-137.
31 | Provenance: Written by B. Frakes and C. Cox, 1986.
32 |
33 | I have re-interpreted areas that use Frakes and Cox's "WordSize"
34 | function. My version may misbehave on short words starting with "y",
35 | but I can't think of any examples.
36 |
37 | The step numbers correspond to Frakes and Cox, and are probably in
38 | Porter's article (which I've not seen).
39 | Porter's algorithm still has rough spots (e.g current/currency, -ings words),
40 | which I've not attempted to cure, although I have added
41 | support for the British -ise suffix.
42 |
43 | =head1 CHANGES
44 |
45 |
46 | 2003.09.28 - Documentation fix
47 |
48 | 2000.09.14 - Forked from the Lingua::Stem::En.pm module to provide
49 | a backward compatibly broken version for people needing
50 | consistent behavior with 0.30 and 0.40 more than accurate
51 | stemming.
52 |
53 | =cut
54 |
55 | #######################################################################
56 | # Initialization
57 | #######################################################################
58 |
59 | use strict;
60 | use Exporter;
61 | use Carp;
62 | use vars qw (@ISA @EXPORT_OK @EXPORT %EXPORT_TAGS $VERSION);
63 | BEGIN {
64 | @ISA = qw (Exporter);
65 | @EXPORT = ();
66 | @EXPORT_OK = qw (stem clear_stem_cache stem_caching);
67 | %EXPORT_TAGS = ();
68 | }
69 | $VERSION = "2.13";
70 |
71 | my $Stem_Caching = 0;
72 | my $Stem_Cache = {};
73 |
74 | #
75 | #V Porter.pm V2.11 25 Aug 2000 stemming cache
76 | # Porter.pm V2.1 21 Jun 1999 with '&$sub if defined' not 'eval ""'
77 | # Porter.pm V2.0 25 Nov 1994 (for Perl 5.000)
78 | # porter.pl V1.0 10 Aug 1994 (for Perl 4.036)
79 | # Jim Richardson, University of Sydney
80 | # jimr@maths.usyd.edu.au or http://www.maths.usyd.edu.au:8000/jimr.html
81 |
82 | # Find a canonical stem for a word, assumed to consist entirely of
83 | # lower-case letters. The approach is from
84 | #
85 | # M. F. Porter, An algorithm for suffix stripping, Program (Automated
86 | # Library and Information Systems) 14 (3) 130-7, July 1980.
87 | #
88 | # This algorithm is used by WAIS: for example, see freeWAIS-0.3 at
89 | #
90 | # http://kudzu.cnidr.org/cnidr_projects/cnidr_projects.html
91 |
92 | # Some additional rules are used here, mainly to allow for British spellings
93 | # like -ise. They are marked ** in the code.
94 |
95 | # Initialization required before using subroutine stem:
96 |
97 | # We count syllables slightly differently from Porter: we say the syllable
98 | # count increases on each occurrence in the word of an adjacent pair
99 | #
100 | # [aeiouy][^aeiou]
101 | #
102 | # This avoids any need to define vowels and consonants, or confusion over
103 | # 'y'. It also works slightly better: our definition gives two syllables
104 | # in 'yttrium', while Porter's gives only one because the initial 'y' is
105 | # taken to be a consonant. But it is not quite obvious: for example,
106 | # consider 'mayfly' where, when working backwards (see below), the 'yf'
107 | # matches the above pattern, even though it is the 'ay' which in Porter's
108 | # terms increments the syllable count.
109 | #
110 | # We wish to match the above in context, working backwards from the end of
111 | # the word: the appropriate regular expression is
112 |
113 | my $syl = '[aeiou]*[^aeiou][^aeiouy]*[aeiouy]';
114 |
115 | # (This works because [^aeiouy] is a subset of [^aeiou].) If we want two
116 | # syllables ("m>1" in Porter's terminology) we can just match $syl$syl.
117 |
118 | # For step 1b we need to be able to detect the presence of a vowel: here
119 | # we revert to Porter's definition that a vowel is [aeiou], or y preceded
120 | # by a consonant. (If the . below is a vowel, then the . is the desired
121 | # vowel; if the . is a consonant the y is the desired vowel.)
122 |
123 | my $hasvow = '[^aeiouy]*([aeiou]|y.)';
124 |
125 | =head1 METHODS
126 |
127 | =cut
128 |
129 | #######################################################################
130 |
131 | =over 4
132 |
133 | =item stem({ -words => \@words, -locale => 'en', -exceptions => \%exceptions });
134 |
135 | Stems a list of passed words using the rules of US English. Returns
136 | an anonymous array reference to the stemmed words.
137 |
138 | Example:
139 |
140 | my $stemmed_words = Lingua::Stem::EnBroken::stem({ -words => \@words,
141 | -locale => 'en',
142 | -exceptions => \%exceptions,
143 | });
144 |
145 | =back
146 |
147 | =cut
148 |
149 | sub stem {
150 | return [] if ($#_ == -1);
151 | my $parm_ref;
152 | if (ref $_[0]) {
153 | $parm_ref = shift;
154 | } else {
155 | $parm_ref = { @_ };
156 | }
157 |
158 | my $words = [];
159 | my $locale = 'en';
160 | my $exceptions = {};
161 | foreach (keys %$parm_ref) {
162 | my $key = lc ($_);
163 | if ($key eq '-words') {
164 | @$words = @{$parm_ref->{$key}};
165 | } elsif ($key eq '-exceptions') {
166 | $exceptions = $parm_ref->{$key};
167 | } elsif ($key eq '-locale') {
168 | $locale = $parm_ref->{$key};
169 | } else {
170 | croak (__PACKAGE__ . "::stem() - Unknown parameter '$key' with value '$parm_ref->{$key}'\n");
171 | }
172 | }
173 |
174 | local( $_ );
175 | foreach (@$words) {
176 |
177 | # Flatten case
178 | $_ = lc $_;
179 |
180 | # Check against exceptions list
181 | if (exists $exceptions->{$_}) {
182 | $_ = $exceptions->{$_};
183 | next;
184 | }
185 |
186 | # Check against cache of stemmed words
187 | my $original_word = $_;
188 | if ($Stem_Caching && exists $Stem_Cache->{$original_word}) {
189 | $_ = $Stem_Cache->{$original_word};
190 | next;
191 | }
192 |
193 | # Step 0 - remove punctuation
194 | s/'s$//; s/^[^a-z]+//; s/[^a-z]+$//;
195 | next unless /^[a-z]+$/;
196 |
197 | # Reverse the word so we can easily apply pattern matching to the end:
198 | $_ = reverse $_;
199 |
200 | # Step 1a: plurals -- sses->ss, ies->i, ss->ss, s->0
201 |
202 | m!^s! && ( s!^se(ss|i)!$1! || s!^s([^s])!$1! );
203 |
204 | # Step 1b: participles -- SYLeed->SYLee, VOWed->VOW, VOWing->VOW;
205 | # but ated->ate etc
206 |
207 | s!^dee($syl)!ee$1!o ||
208 | (
209 | s!^(de|gni)($hasvow)!$2!o &&
210 | (
211 | # at->ate, bl->ble, iz->ize, is->ise
212 | s!^(ta|lb|[sz]i)!e$1! || # ** ise as well as ize
213 | # CC->C (C consonant other than l, s, z)
214 | s!^([^aeioulsz])\1!$1! ||
215 | # (m=1) CVD->CVDe (C consonant, V vowel, D consonant not w, x, y)
216 | s!^([^aeiouwxy][aeiouy][^aeiou]+)$!e$1!
217 | )
218 | );
219 |
220 | # Step 1c: change y to i: happy->happi, sky->sky
221 |
222 | s!^y($hasvow)!i$1!o;
223 |
224 | # Step 2: double and triple suffices (part 1)
225 |
226 | # Switch on last three letters (fails harmlessly if subroutine undefined) --
227 | # thanks to Ian Phillipps who wrote
228 | # CPAN authors/id/IANPX/Stem-0.1.tar.gz
229 | # for suggesting the replacement of
230 | # eval( '&S2' . unpack( 'a3', $_ ) );
231 | # (where the eval ignores undefined subroutines) by the much faster
232 | # eval { &{ 'S2' . substr( $_, 0, 3 ) } };
233 | # But the following is slightly faster still:
234 |
235 | my $sub;
236 |
237 | &$sub if defined &{ $sub = 'S2' . substr( $_, 0, 3 ) };
238 |
239 | # Step 3: double and triple suffices, etc (part 2)
240 |
241 | &$sub if defined &{ $sub = 'S3' . substr( $_, 0, 3 ) };
242 |
243 | # Step 4: single suffices on polysyllables
244 |
245 | &$sub if defined &{ $sub = 'S4' . substr( $_, 0, 2 ) };
246 |
247 | # Step 5a: tidy up final e -- probate->probat, rate->rate; cease->ceas
248 |
249 | m!^e! && ( s!^e($syl$syl)!$1!o ||
250 |
251 | # Porter's ( m=1 and not *o ) E where o = cvd with d a consonant
252 | # not w, x or y:
253 |
254 | ! m!^e[^aeiouwxy][aeiouy][^aeiou]! && # not *o E
255 | s!^e($syl[aeiouy]*[^aeiou]*)$!$1!o # m=1
256 | );
257 |
258 | # Step 5b: double l -- controll->control, roll->roll
259 | # ** Note correction: Porter has m>1 here ($syl$syl), but it seems m>0
260 | # ($syl) is wanted to strip an l off controll.
261 |
262 | s!^ll($syl)!l$1!o;
263 |
264 | $_ = scalar( reverse $_ );
265 |
266 | $Stem_Cache->{$original_word} = $_ if $Stem_Caching;
267 | }
268 | $Stem_Cache = {} if ($Stem_Caching < 2);
269 |
270 | return $words;
271 | }
272 |
273 | ##############################################################
274 |
275 | =over 4
276 |
277 | =item stem_caching({ -level => 0|1|2 });
278 |
279 | Sets the level of stem caching.
280 |
281 | '0' means 'no caching'. This is the default level.
282 |
283 | '1' means 'cache per run'. This caches stemming results during a single
284 | call to 'stem'.
285 |
286 | '2' means 'cache indefinitely'. This caches stemming results until
287 | either the process exits or the 'clear_stem_cache' method is called.
288 |
289 | =back
290 |
291 | =cut
292 |
293 | sub stem_caching {
294 | my $parm_ref;
295 | if (ref $_[0]) {
296 | $parm_ref = shift;
297 | } else {
298 | $parm_ref = { @_ };
299 | }
300 | my $caching_level = $parm_ref->{-level};
301 | if (defined $caching_level) {
302 | if ($caching_level !~ m/^[012]$/) {
303 | croak(__PACKAGE__ . "::stem_caching() - Legal values are '0','1' or '2'. '$caching_level' is not a legal value");
304 | }
305 | $Stem_Caching = $caching_level;
306 | }
307 | return $Stem_Caching;
308 | }
309 |
310 | ##############################################################
311 |
312 | =over 4
313 |
314 | =item clear_stem_cache;
315 |
316 | Clears the cache of stemmed words
317 |
318 | =back
319 |
320 | =cut
321 |
322 | sub clear_stem_cache {
323 | $Stem_Cache = {};
324 | }
325 |
326 | ##############################################################
327 |
328 | =head1 NOTES
329 |
330 | This code is almost entirely derived from the Porter 2.1 module
331 | written by Jim Richardson.
332 |
333 | =head1 SEE ALSO
334 |
335 | Lingua::Stem
336 |
337 | =head1 AUTHOR
338 |
339 | Jim Richardson, University of Sydney
340 | jimr@maths.usyd.edu.au or http://www.maths.usyd.edu.au:8000/jimr.html
341 |
342 | Integration in Lingua::Stem by
343 | Benjamin Franz, FreeRun Technologies,
344 | snowhare@nihongo.org or http://www.nihongo.org/snowhare/
345 |
346 | =head1 COPYRIGHT
347 |
348 | Jim Richardson, University of Sydney
349 | Benjamin Franz, FreeRun Technologies
350 |
351 | This code is freely available under the same terms as Perl.
352 |
353 | =head1 BUGS
354 |
355 | =head1 TODO
356 |
357 | =cut
358 |
359 | 1;
360 |
--------------------------------------------------------------------------------
/cgi/Net/OpenID/VerifiedIdentity.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 | use Carp ();
3 |
4 | ############################################################################
5 | package Net::OpenID::VerifiedIdentity;
6 | use fields (
7 | 'identity', # the verified identity URL
8 | 'id_uri', # the verified identity's URI object
9 |
10 | 'claimed_identity', # The ClaimedIdentity object that we've verified
11 | 'semantic_info', # The "semantic info" (RSS URLs, etc) at the verified identity URL
12 |
13 | 'consumer', # The Net::OpenID::Consumer module which created us
14 |
15 | 'signed_fields' , # hashref of key->value of things that were signed. without "openid." prefix
16 | 'signed_message', # the signed fields as an IndirectMessage object. Created when needed.
17 | );
18 | use URI;
19 |
20 | sub new {
21 | my Net::OpenID::VerifiedIdentity $self = shift;
22 | $self = fields::new( $self ) unless ref $self;
23 | my %opts = @_;
24 |
25 | $self->{'consumer'} = delete $opts{'consumer'};
26 |
27 | if ($self->{'claimed_identity'} = delete $opts{'claimed_identity'}) {
28 | $self->{identity} = $self->{claimed_identity}->claimed_url;
29 | unless ($self->{'id_uri'} = URI->new($self->{identity})) {
30 | return $self->{'consumer'}->_fail("invalid_uri");
31 | }
32 | }
33 |
34 | for my $par (qw(signed_fields)) {
35 | $self->$par(delete $opts{$par});
36 | }
37 |
38 | Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
39 | return $self;
40 | }
41 |
42 | sub url {
43 | my Net::OpenID::VerifiedIdentity $self = shift;
44 | return $self->{'identity'};
45 | }
46 |
47 | sub display {
48 | my Net::OpenID::VerifiedIdentity $self = shift;
49 | return DisplayOfURL($self->{'identity'});
50 | }
51 |
52 | sub _semantic_info_hash {
53 | my ($self) = @_;
54 | return $self->{semantic_info} if $self->{semantic_info};
55 | my $sem_info = $self->{claimed_identity}->semantic_info;
56 | $self->{semantic_info} = {
57 | 'foaf' => $self->_identity_relative_uri($sem_info->{"foaf"}),
58 | 'foafmaker' => $sem_info->{"foaf.maker"},
59 | 'rss' => $self->_identity_relative_uri($sem_info->{"rss"}),
60 | 'atom' => $self->_identity_relative_uri($sem_info->{"atom"}),
61 | };
62 | return $self->{semantic_info};
63 | }
64 |
65 | sub _identity_relative_uri {
66 | my $self = shift;
67 | my $url = shift;
68 |
69 | return $url if ref $url;
70 | return undef unless $url;
71 | return URI->new_abs($url, $self->{'id_uri'});
72 | }
73 |
74 | sub signed_fields { &_getset; }
75 |
76 | sub foaf { &_getset_semurl; }
77 | sub rss { &_getset_semurl; }
78 | sub atom { &_getset_semurl; }
79 | sub foafmaker { &_getset_sem; }
80 |
81 | sub declared_foaf { &_dec_semurl; }
82 | sub declared_rss { &_dec_semurl; }
83 | sub declared_atom { &_dec_semurl; }
84 |
85 | sub extension_fields {
86 | my ($self, $ns_uri) = @_;
87 | return $self->_extension_fields($ns_uri, $self->{consumer}->message);
88 | }
89 |
90 | sub signed_extension_fields {
91 | my ($self, $ns_uri) = @_;
92 |
93 | return $self->_extension_fields($ns_uri, $self->signed_message);
94 | }
95 |
96 | sub _extension_fields {
97 | my ($self, $ns_uri, $args) = @_;
98 |
99 | return $args->get_ext($ns_uri);
100 | }
101 |
102 | sub signed_message {
103 | my ($self) = @_;
104 |
105 | return $self->{signed_message} if $self->{signed_message};
106 |
107 | # This is maybe a bit hacky.
108 | # We need to synthesize an IndirectMessage object
109 | # representing the signed fields, which means
110 | # that we need to fake up the mandatory message
111 | # arguments that probably weren't signed.
112 |
113 | my %args = map { 'openid.'.$_ => $self->{signed_fields}{$_} } keys %{$self->{signed_fields}};
114 |
115 | my $real_message = $self->{consumer}->message;
116 | if ($real_message->protocol_version == 1) {
117 | # OpenID 1.1 just needs a mode.
118 | $args{'openid.mode'} = 'id_res';
119 | }
120 | else {
121 | # OpenID 2.2 needs the namespace URI as well
122 | $args{'openid.ns'} = 'http://specs.openid.net/auth/2.0';
123 | $args{'openid.mode'} = 'id_res';
124 | }
125 |
126 | my $message = Net::OpenID::IndirectMessage->new(\%args);
127 |
128 | return $self->{signed_message} = $message;
129 | }
130 |
131 | sub _getset {
132 | my $self = shift;
133 | my $param = (caller(1))[3];
134 | $param =~ s/.+:://;
135 |
136 | if (@_) {
137 | my $val = shift;
138 | Carp::croak("Too many parameters") if @_;
139 | $self->{$param} = $val;
140 | }
141 | return $self->{$param};
142 | }
143 |
144 | sub _getset_sem {
145 | my $self = shift;
146 | my $param = (caller(1))[3];
147 | $param =~ s/.+:://;
148 |
149 | my $info = $self->_semantic_info_hash;
150 |
151 | if (my $value = shift) {
152 | Carp::croak("Too many parameters") if @_;
153 | $info->{$param} = $value;
154 | }
155 | return $info->{$param};
156 | }
157 |
158 | sub _getset_semurl {
159 | my $self = shift;
160 | my $param = (caller(1))[3];
161 | $param =~ s/.+:://;
162 |
163 | my $info = $self->_semantic_info_hash;
164 |
165 | if (my $surl = shift) {
166 | Carp::croak("Too many parameters") if @_;
167 |
168 | # TODO: make absolute URL from possibly relative one
169 | my $abs = URI->new_abs($surl, $self->{'id_uri'});
170 | $info->{$param} = $abs;
171 | }
172 |
173 | my $uri = $info->{$param};
174 | return $uri && _url_is_under($self->{'id_uri'}, $uri) ? $uri->as_string : undef;
175 | }
176 |
177 | sub _dec_semurl {
178 | my $self = shift;
179 | my $param = (caller(1))[3];
180 | $param =~ s/.+::declared_//;
181 |
182 | my $info = $self->_semantic_info_hash;
183 |
184 | my $uri = $info->{$param};
185 | return $uri ? $uri->as_string : undef;
186 | }
187 |
188 | sub DisplayOfURL {
189 | my $url = shift;
190 | my $dev_mode = shift;
191 |
192 | return $url unless
193 | $url =~ m!^https?://([^/]+)(/.*)?$!;
194 |
195 | my ($host, $path) = ($1, $2);
196 | $host = lc($host);
197 |
198 | if ($dev_mode) {
199 | $host =~ s!^dev\.!!;
200 | $host =~ s!:\d+!!;
201 | }
202 |
203 | $host =~ s/:.+//;
204 | $host =~ s/^www\.//i;
205 |
206 | if (length($path) <= 1) {
207 | return $host;
208 | }
209 |
210 | # obvious username
211 | if ($path =~ m!^/~([^/]+)/?$! ||
212 | $path =~ m!^/(?:users?|members?)/([^/]+)/?$!) {
213 | return "$1 [$host]";
214 | }
215 |
216 | if ($host =~ m!^profile\.(.+)!i) {
217 | my $site = $1;
218 | if ($path =~ m!^/([^/]+)/?$!) {
219 | return "$1 [$site]";
220 | }
221 | }
222 |
223 | return $url;
224 | }
225 |
226 | # FIXME: duplicated in Net::OpenID::Server
227 | sub _url_is_under {
228 | my ($root, $test, $err_ref) = @_;
229 |
230 | my $err = sub {
231 | $$err_ref = shift if $err_ref;
232 | return undef;
233 | };
234 |
235 | my $ru = ref $root ? $root : URI->new($root);
236 | return $err->("invalid root scheme") unless $ru->scheme =~ /^https?$/;
237 | my $tu = ref $test ? $test : URI->new($test);
238 | return $err->("invalid test scheme") unless $tu->scheme =~ /^https?$/;
239 | return $err->("schemes don't match") unless $ru->scheme eq $tu->scheme;
240 | return $err->("ports don't match") unless $ru->port == $tu->port;
241 |
242 | # check hostnames
243 | my $ru_host = $ru->host;
244 | my $tu_host = $tu->host;
245 | my $wildcard_host = 0;
246 | if ($ru_host =~ s!^\*\.!!) {
247 | $wildcard_host = 1;
248 | }
249 | unless ($ru_host eq $tu_host) {
250 | if ($wildcard_host) {
251 | return $err->("host names don't match") unless
252 | $tu_host =~ /\.\Q$ru_host\E$/;
253 | } else {
254 | return $err->("host names don't match");
255 | }
256 | }
257 |
258 | # check paths
259 | my $ru_path = $ru->path || "/";
260 | my $tu_path = $tu->path || "/";
261 | $ru_path .= "/" unless $ru_path =~ m!/$!;
262 | $tu_path .= "/" unless $tu_path =~ m!/$!;
263 | return $err->("path not a subpath") unless $tu_path =~ m!^\Q$ru_path\E!;
264 |
265 | return 1;
266 | }
267 |
268 | 1;
269 |
270 | __END__
271 |
272 | =head1 NAME
273 |
274 | Net::OpenID::VerifiedIdentity - object representing a verified OpenID identity
275 |
276 | =head1 SYNOPSIS
277 |
278 | use Net::OpenID::Consumer;
279 | my $csr = Net::OpenID::Consumer->new;
280 | ....
281 | my $vident = $csr->verified_identity
282 | or die $csr->err;
283 |
284 | my $url = $vident->url;
285 |
286 |
287 | =head1 DESCRIPTION
288 |
289 | After L verifies a user's identity and does the
290 | signature checks, it gives you this Net::OpenID::VerifiedIdentity
291 | object, from which you can learn more about the user.
292 |
293 | =head1 METHODS
294 |
295 | =over 4
296 |
297 | =item $vident->B
298 |
299 | Returns the URL (as a scalar) that was verified. (Remember, an OpenID
300 | is just a URL.)
301 |
302 | =item $vident->B
303 |
304 | Returns the a short "display form" of the verified URL using a couple
305 | brain-dead patterns. For instance, the identity
306 | "http://www.foo.com/~bob/" will map to "bob [foo.com]" The www. prefix
307 | is removed, as well as http, and a username is looked for, in either
308 | the tilde form, or "/users/USERNAME" or "/members/USERNAME". If the
309 | path component is empty or just "/", then the display form is just the
310 | hostname, so "http://myblog.com/" is just "myblog.com".
311 |
312 | Suggestions for improving this function are welcome, but you'll probably
313 | get more satisfying results if you make use of the data returned by
314 | the Simple Registration (SREG) extension, which allows the user to
315 | choose a preferred nickname to use on your site.
316 |
317 | =item $vident->B($ns_uri)
318 |
319 | Return the fields from the given extension namespace, if any, that
320 | were included in the assertion request. The fields are returned in
321 | a hashref.
322 |
323 | In most cases you'll probably want to use B instead,
324 | to avoid attacks where a man-in-the-middle alters the extension fields in transit.
325 |
326 | Note that for OpenID 1.1 transactions only Simple Registration (SREG) 1.1
327 | is supported.
328 |
329 | =item $vident->B($ns_uri)
330 |
331 | The same as B except that only fields that were signed
332 | as part of the assertion are included in the returned hashref. For example,
333 | if you included a Simple Registration request in your initial message,
334 | you might fetch the results (if any) like this:
335 |
336 | $sreg = $vident->signed_extension_fields(
337 | 'http://openid.net/extensions/sreg/1.1',
338 | );
339 |
340 | An important gotcha to bear in mind is that for OpenID 2.0 responses
341 | no extension fields can be considered signed unless the corresponding
342 | extension namespace declaration is also signed. If that is not the case,
343 | this method will behave as if no extension fields for that URI were signed.
344 |
345 | =item $vident->B
346 |
347 | =item $vident->B
348 |
349 | =item $vident->B
350 |
351 | =item $vident->B
352 |
353 | =item $vident->B
354 |
355 | =item $vident->B
356 |
357 | Returns the absolute URLs (as scalars) of the user's RSS, Atom, and
358 | FOAF XML documents that were also found in their HTML's EheadE
359 | section. The short versions will only return a URL if they're below
360 | the root URL that was verified. If you want to get at the user's
361 | declared rss/atom/foaf, even if it's on a different host or parent
362 | directory, use the delcared_* versions, which don't have the additional
363 | checks.
364 |
365 | 2005-05-24: A future module will take a Net::OpenID::VerifiedIdentity
366 | object and create an OpenID profile object so you don't have to
367 | manually parse all those documents to get profile information.
368 |
369 | =item $vident->B
370 |
371 | Returns the value of the C meta tag, if declared.
372 |
373 | =back
374 |
375 | =head1 COPYRIGHT, WARRANTY, AUTHOR
376 |
377 | See L for author, copyrignt and licensing information.
378 |
379 | =head1 SEE ALSO
380 |
381 | L
382 |
383 | L
384 |
385 | L
386 |
387 | Website: L
388 |
--------------------------------------------------------------------------------
/cgi/Net/OpenID/ClaimedIdentity.pm:
--------------------------------------------------------------------------------
1 | use strict;
2 | use Carp ();
3 |
4 | ############################################################################
5 | package Net::OpenID::ClaimedIdentity;
6 | use fields (
7 | 'identity', # the canonical URL that was found, following redirects
8 | 'server', # author-identity identity server endpoint
9 | 'consumer', # ref up to the Net::OpenID::Consumer which generated us
10 | 'delegate', # the delegated URL actually asserted by the server
11 | 'protocol_version', # The version of the OpenID Authentication Protocol that is used
12 | 'semantic_info', # Stuff that we've discovered in the identifier page's metadata
13 | 'extension_args', # Extension arguments that the caller wants to add to the request
14 | );
15 |
16 | sub new {
17 | my Net::OpenID::ClaimedIdentity $self = shift;
18 | $self = fields::new( $self ) unless ref $self;
19 | my %opts = @_;
20 | for my $f (qw( identity server consumer delegate protocol_version semantic_info )) {
21 | $self->{$f} = delete $opts{$f};
22 | }
23 |
24 | $self->{protocol_version} ||= 1;
25 | unless ($self->{protocol_version} == 1 || $self->{protocol_version} == 2) {
26 | Carp::croak("Unsupported protocol version");
27 | }
28 |
29 | # lowercase the scheme and hostname
30 | $self->{'identity'} =~ s!^(https?://.+?)(/(?:.*))?$!lc($1) . $2!ie;
31 |
32 | $self->{extension_args} = {};
33 |
34 | Carp::croak("unknown options: " . join(", ", keys %opts)) if %opts;
35 | return $self;
36 | }
37 |
38 | sub claimed_url {
39 | my Net::OpenID::ClaimedIdentity $self = shift;
40 | Carp::croak("Too many parameters") if @_;
41 | return $self->{'identity'};
42 | }
43 |
44 | sub delegated_url {
45 | my Net::OpenID::ClaimedIdentity $self = shift;
46 | Carp::croak("Too many parameters") if @_;
47 | return $self->{'delegate'};
48 | }
49 |
50 | sub identity_server {
51 | my Net::OpenID::ClaimedIdentity $self = shift;
52 | Carp::croak("Too many parameters") if @_;
53 | return $self->{server};
54 | }
55 |
56 | sub protocol_version {
57 | my Net::OpenID::ClaimedIdentity $self = shift;
58 | Carp::croak("Too many parameters") if @_;
59 | return $self->{protocol_version};
60 | }
61 |
62 | sub semantic_info {
63 | my Net::OpenID::ClaimedIdentity $self = shift;
64 | Carp::croak("Too many parameters") if @_;
65 | return $self->{semantic_info} if $self->{semantic_info};
66 | my $final_url = '';
67 | my $info = $self->{consumer}->_find_semantic_info($self->claimed_url, \$final_url);
68 | # Don't return anything if the URL has changed. Something bad may be happening.
69 | $info = {} if $final_url ne $self->claimed_url;
70 | return $self->{semantic_info} = $info;
71 | }
72 |
73 | sub set_extension_args {
74 | my Net::OpenID::ClaimedIdentity $self = shift;
75 | my $ext_uri = shift;
76 | my $args = shift;
77 | Carp::croak("Too many parameters") if @_;
78 | Carp::croak("No extension URI given") unless $ext_uri;
79 | Carp::croak("Expecting hashref of args") if defined($args) && ref $args ne 'HASH';
80 |
81 | $self->{extension_args}{$ext_uri} = $args;
82 | }
83 |
84 | sub check_url {
85 | my Net::OpenID::ClaimedIdentity $self = shift;
86 | my (%opts) = @_;
87 |
88 | my $return_to = delete $opts{'return_to'};
89 | my $trust_root = delete $opts{'trust_root'};
90 | my $delayed_ret = delete $opts{'delayed_return'};
91 | my $force_reassociate = delete $opts{'force_reassociate'};
92 | my $use_assoc_handle = delete $opts{'use_assoc_handle'};
93 | my $actually_return_association = delete $opts{'actually_return_association'};
94 |
95 | Carp::croak("Unknown options: " . join(", ", keys %opts)) if %opts;
96 | Carp::croak("Invalid/missing return_to") unless $return_to =~ m!^https?://!;
97 |
98 | my $csr = $self->{consumer};
99 |
100 | my $ident_server = $self->{server} or
101 | Carp::croak("No identity server");
102 |
103 | # get an assoc (or undef for dumb mode)
104 | my $assoc;
105 | if ($use_assoc_handle) {
106 | $assoc = Net::OpenID::Association::handle_assoc($csr, $ident_server, $use_assoc_handle);
107 | } else {
108 | $assoc = Net::OpenID::Association::server_assoc($csr, $ident_server, $force_reassociate, (
109 | protocol_version => $self->protocol_version,
110 | ));
111 | }
112 |
113 | # for the openid-test project: (doing interop testing)
114 | if ($actually_return_association) {
115 | return $assoc;
116 | }
117 |
118 | my $identity_arg = $self->{'delegate'} || $self->{'identity'};
119 |
120 | # make a note back to ourselves that we're using a delegate
121 | # but only in the 1.1 case because 2.0 has a core field for this
122 | if ($self->{'delegate'} && $self->protocol_version == 1) {
123 | OpenID::util::push_url_arg(\$return_to,
124 | "oic.identity", $self->{identity});
125 | }
126 |
127 | # add a HMAC-signed time so we can verify the return_to URL wasn't spoofed
128 | my $sig_time = time();
129 | my $c_secret = $csr->_get_consumer_secret($sig_time);
130 | my $sig = substr(OpenID::util::hmac_sha1_hex($sig_time, $c_secret), 0, 20);
131 | OpenID::util::push_url_arg(\$return_to,
132 | "oic.time", "${sig_time}-$sig");
133 |
134 | my $curl = $ident_server;
135 | if ($self->protocol_version == 1) {
136 | OpenID::util::push_url_arg(\$curl,
137 | "openid.mode" => ($delayed_ret ? "checkid_setup" : "checkid_immediate"),
138 | "openid.identity" => $identity_arg,
139 | "openid.return_to" => $return_to,
140 |
141 | ($trust_root ? (
142 | "openid.trust_root" => $trust_root
143 | ) : ()),
144 |
145 | ($assoc ? (
146 | "openid.assoc_handle" => $assoc->handle
147 | ) : ()),
148 | );
149 | }
150 | elsif ($self->protocol_version == 2) {
151 | # NOTE: OpenID Auth 2.0 uses different terminology for a bunch
152 | # of things than 1.1 did. This library still uses the 1.1 terminology
153 | # in its API.
154 | OpenID::util::push_openid2_url_arg(\$curl,
155 | "mode" => ($delayed_ret ? "checkid_setup" : "checkid_immediate"),
156 | "claimed_id" => $self->claimed_url,
157 | "identity" => $identity_arg,
158 | "return_to" => $return_to,
159 |
160 | ($trust_root ? (
161 | "realm" => $trust_root
162 | ) : ()),
163 |
164 | ($assoc ? (
165 | "assoc_handle" => $assoc->handle
166 | ) : ()),
167 | );
168 | }
169 |
170 | # Finally we add in the extension arguments, if any
171 | my %ext_url_args = ();
172 | my $ext_idx = 1;
173 | foreach my $ext_uri (keys %{$self->{extension_args}}) {
174 | my $ext_alias;
175 |
176 | if ($self->protocol_version >= 2) {
177 | $ext_alias = 'e'.($ext_idx++);
178 | $ext_url_args{'openid.ns.'.$ext_alias} = $ext_uri;
179 | }
180 | else {
181 | # For OpenID 1.1 only the "SREG" extension is allowed,
182 | # and it must use the "openid.sreg." prefix.
183 | next unless $ext_uri eq "http://openid.net/extensions/sreg/1.1";
184 | $ext_alias = "sreg";
185 | }
186 |
187 | foreach my $k (keys %{$self->{extension_args}{$ext_uri}}) {
188 | $ext_url_args{'openid.'.$ext_alias.'.'.$k} = $self->{extension_args}{$ext_uri}{$k};
189 | }
190 | }
191 | OpenID::util::push_url_arg(\$curl, %ext_url_args) if %ext_url_args;
192 |
193 | $self->{consumer}->_debug("check_url for (del=$self->{delegate}, id=$self->{identity}) = $curl");
194 | return $curl;
195 | }
196 |
197 |
198 | 1;
199 |
200 | __END__
201 |
202 | =head1 NAME
203 |
204 | Net::OpenID::ClaimedIdentity - a not-yet-verified OpenID identity
205 |
206 | =head1 SYNOPSIS
207 |
208 | use Net::OpenID::Consumer;
209 | my $csr = Net::OpenID::Consumer->new;
210 | ....
211 | my $cident = $csr->claimed_identity("bradfitz.com")
212 | or die $csr->err;
213 |
214 | if ($AJAX_mode) {
215 | my $url = $cident->claimed_url;
216 | my $openid_server = $cident->identity_server;
217 | # ... return JSON with those to user agent (whose request was
218 | # XMLHttpRequest, probably)
219 | }
220 |
221 | if ($CLASSIC_mode) {
222 | my $check_url = $cident->check_url(
223 | delayed_return => 1,
224 | return_to => "http://example.com/get-identity.app",
225 | trust_root => "http://*.example.com/",
226 | );
227 | WebApp::redirect($check_url);
228 | }
229 |
230 | =head1 DESCRIPTION
231 |
232 | After L crawls a user's declared identity URL
233 | and finds openid.server link tags in the HTML head, you get this
234 | object. It represents an identity that can be verified with OpenID
235 | (the link tags are present), but hasn't been actually verified yet.
236 |
237 | =head1 METHODS
238 |
239 | =over 4
240 |
241 | =item $url = $cident->B
242 |
243 | The URL, now canonicalized, that the user claims to own. You can't
244 | know whether or not they do own it yet until you send them off to the
245 | check_url, though.
246 |
247 | =item $id_server = $cident->B
248 |
249 | Returns the identity server that will assert whether or not this
250 | claimed identity is valid, and sign a message saying so.
251 |
252 | =item $url = $cident->B
253 |
254 | If the claimed URL is using delegation, this returns the delegated identity that will
255 | actually be sent to the identity server.
256 |
257 | =item $version = $cident->B
258 |
259 | Determines whether this identifier is to be verified by OpenID 1.1
260 | or by OpenID 2.0. Returns C<1> or C<2> respectively. This will
261 | affect the way the C is constructed.
262 |
263 | =item $cident->B($ns_uri, $args)
264 |
265 | If called before you access C, the arguments given in the hashref
266 | $args will be added to the request in the given extension namespace.
267 | For example, to use the Simple Registration (SREG) extension:
268 |
269 | $cident->set_extension_args(
270 | 'http://openid.net/extensions/sreg/1.1',
271 | {
272 | required => 'email',
273 | optional => 'fullname,nickname',
274 | policy_url => 'http://example.com/privacypolicy.html',
275 | },
276 | );
277 |
278 | Note that when making an OpenID 1.1 request, only the Simple Registration
279 | extension is supported. There was no general extension mechanism defined
280 | in OpenID 1.1, so SREG (with the namespace URI as in the example above)
281 | is supported as a special case. All other extension namespaces will
282 | be silently ignored when making a 1.1 request.
283 |
284 | =item $url = $cident->B( %opts )
285 |
286 | Makes the URL that you have to somehow send the user to in order to
287 | validate their identity. The options to put in %opts are:
288 |
289 | =over
290 |
291 | =item C
292 |
293 | The URL that the identity server should redirect the user with either
294 | a verified identity signature -or- a user_setup_url (if the assertion
295 | couldn't be made). This URL may contain query parameters, and the
296 | identity server must preserve them.
297 |
298 | =item C
299 |
300 | The URL that you want the user to actually see and declare trust for.
301 | Your C URL must be at or below your trust_root. Sending
302 | the trust_root is optional, and defaults to your C value,
303 | but it's highly recommended (and prettier for users) to see a simple
304 | trust_root. Note that the trust root may contain a wildcard at the
305 | beginning of the host, like C
306 |
307 | =item C
308 |
309 | If set to a true value, the check_url returned will indicate to the
310 | user's identity server that it has permission to control the user's
311 | user-agent for awhile, giving them real pages (not just redirects) and
312 | lets them bounce around the identity server site for awhile until
313 | the requested assertion can be made, and they can finally be redirected
314 | back to your return_to URL above.
315 |
316 | The default value, false, means that the identity server will
317 | immediately return to your return_to URL with either a "yes" or "no"
318 | answer. In the "no" case, you'll instead have control of what to do,
319 | and you'll be sent the identity server's user_setup_url where you'll
320 | have to somehow send the user (be it link, redirect, or pop-up
321 | window).
322 |
323 | When writing a dynamic "AJAX"-style application, you can't use
324 | delayed_return because the remote site can't usefully take control of
325 | a 1x1 pixel hidden IFRAME, so you'll need to get the user_setup_url
326 | and present it to the user somehow.
327 |
328 | =back
329 |
330 | =back
331 |
332 | =head1 COPYRIGHT, WARRANTY, AUTHOR
333 |
334 | See L for author, copyrignt and licensing information.
335 |
336 | =head1 SEE ALSO
337 |
338 | L
339 |
340 | L
341 |
342 | L
343 |
344 | Website: L
345 |
346 |
--------------------------------------------------------------------------------