r34709 - in /branches/upstream/libnet-google-authsub-perl: ./ current/ current/lib/ current/lib/Net/ current/lib/Net/Google/ current/lib/Net/Google/AuthSub/ current/t/

mogaal-guest at users.alioth.debian.org mogaal-guest at users.alioth.debian.org
Mon May 4 06:17:58 UTC 2009


Author: mogaal-guest
Date: Mon May  4 06:17:14 2009
New Revision: 34709

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=34709
Log:
[svn-inject] Installing original source of libnet-google-authsub-perl

Added:
    branches/upstream/libnet-google-authsub-perl/
    branches/upstream/libnet-google-authsub-perl/current/
    branches/upstream/libnet-google-authsub-perl/current/Build.PL   (with props)
    branches/upstream/libnet-google-authsub-perl/current/Changes
    branches/upstream/libnet-google-authsub-perl/current/MANIFEST
    branches/upstream/libnet-google-authsub-perl/current/META.yml
    branches/upstream/libnet-google-authsub-perl/current/Makefile.PL
    branches/upstream/libnet-google-authsub-perl/current/lib/
    branches/upstream/libnet-google-authsub-perl/current/lib/Net/
    branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/
    branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub/
    branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub.pm
    branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub/Response.pm
    branches/upstream/libnet-google-authsub-perl/current/t/
    branches/upstream/libnet-google-authsub-perl/current/t/00use.t
    branches/upstream/libnet-google-authsub-perl/current/t/pod-coverage.t
    branches/upstream/libnet-google-authsub-perl/current/t/pod.t

Added: branches/upstream/libnet-google-authsub-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/Build.PL?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/Build.PL (added)
+++ branches/upstream/libnet-google-authsub-perl/current/Build.PL Mon May  4 06:17:14 2009
@@ -1,0 +1,16 @@
+use strict;
+use Module::Build;
+
+my $build = Module::Build
+  ->new( module_name  => "Net::Google::AuthSub",
+         version_from => 'lib/Net/Google/AuthSub.pm',
+         requires     => {
+                          'Test::More'            => '0.62',
+                          'LWP::UserAgent'        => 0,
+                          'URI'                   => 0,
+                        },
+         create_makefile_pl => 'traditional',
+       );
+
+$build->create_build_script;
+

Propchange: branches/upstream/libnet-google-authsub-perl/current/Build.PL
------------------------------------------------------------------------------
    svn:executable = 

Added: branches/upstream/libnet-google-authsub-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/Changes?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/Changes (added)
+++ branches/upstream/libnet-google-authsub-perl/current/Changes Mon May  4 06:17:14 2009
@@ -1,0 +1,13 @@
+- 0.4 28th July 2008
+Allow proxies
+ 
+- 0.3 28th July 2007
+Dopplr have fixed API bugs, remove Dopplr compat and JSON.
+Make cuddled Auth requests the default
+Use GET instead of POST where required
+
+- 0.2 16th July 2007
+Forgot to have JSON dependency
+
+- 0.1 16th July 2007
+Initial relese

Added: branches/upstream/libnet-google-authsub-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/MANIFEST?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/MANIFEST (added)
+++ branches/upstream/libnet-google-authsub-perl/current/MANIFEST Mon May  4 06:17:14 2009
@@ -1,0 +1,10 @@
+Build.PL
+Changes
+lib/Net/Google/AuthSub.pm
+lib/Net/Google/AuthSub/Response.pm
+MANIFEST			This list of files
+t/00use.t
+t/pod-coverage.t
+t/pod.t
+Makefile.PL
+META.yml

Added: branches/upstream/libnet-google-authsub-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/META.yml?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/META.yml (added)
+++ branches/upstream/libnet-google-authsub-perl/current/META.yml Mon May  4 06:17:14 2009
@@ -1,0 +1,21 @@
+---
+name: Net-Google-AuthSub
+version: 0.4
+author:
+  - 'Simon Wistow <simon at thegestalt.org>'
+abstract: interact with sites that implement Google style AuthSub
+license: unknown
+requires:
+  LWP::UserAgent: 0
+  Test::More: 0.62
+  URI: 0
+provides:
+  Net::Google::AuthSub:
+    file: lib/Net/Google/AuthSub.pm
+    version: 0.4
+  Net::Google::AuthSub::Response:
+    file: lib/Net/Google/AuthSub/Response.pm
+generated_by: Module::Build version 0.2808
+meta-spec:
+  url: http://module-build.sourceforge.net/META-spec-v1.2.html
+  version: 1.2

Added: branches/upstream/libnet-google-authsub-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/Makefile.PL?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/Makefile.PL (added)
+++ branches/upstream/libnet-google-authsub-perl/current/Makefile.PL Mon May  4 06:17:14 2009
@@ -1,0 +1,16 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+          'NAME' => 'Net::Google::AuthSub',
+          'VERSION_FROM' => 'lib/Net/Google/AuthSub.pm',
+          'PREREQ_PM' => {
+                           'LWP::UserAgent' => '0',
+                           'Test::More' => '0.62',
+                           'URI' => '0'
+                         },
+          'INSTALLDIRS' => 'site',
+          'EXE_FILES' => [],
+          'PL_FILES' => {}
+        )
+;

Added: branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub.pm?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub.pm (added)
+++ branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub.pm Mon May  4 06:17:14 2009
@@ -1,0 +1,403 @@
+package Net::Google::AuthSub;
+
+use strict;
+use vars qw($VERSION $APP_NAME);
+use LWP::UserAgent;
+use HTTP::Request::Common;
+use Net::Google::AuthSub::Response;
+use URI;
+
+$VERSION  = '0.4';
+$APP_NAME = __PACKAGE__."-".$VERSION;
+
+use constant CLIENT_LOGIN => 0;
+use constant AUTH_SUB     => 1;
+
+=head1 NAME
+
+Net::Google::AuthSub - interact with sites that implement Google style AuthSub
+
+=head1 SYNOPSIS
+
+
+    my $auth = Net::Google::AuthSub->new;
+    my $response = $auth->login($user, $pass);
+
+    if ($response->is_success) {
+        print "Hurrah! Logged in\n";
+    } else {
+        die "Login failed: ".$response->error."\n";
+    }
+
+    my %params = $auth->auth_params;
+    $params{Content_Type}             = 'application/atom+xml; charset=UTF-8';
+    $params{Content}                  = $xml;
+    $params{'X-HTTP-Method-Override'} = 'DELETE';        
+
+    my $request = POST $url, %params;
+    my $r = $user_agent->request( $request );
+
+
+=head1 ABOUT AUTHSUB
+
+AuthSub is Google's method of authentication for their web 
+services. It is also used by other web sites.
+
+You can read more about it here.
+
+    http://code.google.com/apis/accounts/Authentication.html
+
+A Google Group for AuthSub is here.
+
+    http://groups.google.com/group/Google-Accounts-API
+
+=head1 DEALING WITH CAPTCHAS
+
+If a login response fails then it may set the error code to
+'CaptchRequired' and the response object will allow you to 
+retrieve the C<captchatoken> and C<captchaurl> fields.
+
+The C<captchaurl> will be the url to a captcha image or you 
+can show the user the web page
+
+    https://www.google.com/accounts/DisplayUnlockCaptcha
+
+Then retry the login attempt passing in the parameters 
+C<logintoken> (which is the value of C<captchatoken>) and 
+C<logincaptcha> which is the user's answer to the CAPTCHA.
+
+
+    my $auth = Net::Google::AuthSub->new;
+    my $res  = $auth->login($user, $pass);
+
+    if (!$res->is_success && $res->error eq 'CaptchaRequired') {
+        my $answer = display_captcha($res->captchaurl);
+        $auth->login($user, $pass, logintoken => $res->captchatoken, logincaptcha => $answer);
+    }
+
+
+You can read more here
+
+    http://code.google.com/apis/accounts/AuthForInstalledApps.html#Using
+
+=head1 METHODS
+
+=cut
+
+=head2 new [param[s]]
+
+Return a new authorisation object. The options are
+
+=over 4
+
+=item url
+
+The base url of the web service to authenticate against.
+
+Defaults to C<https://google.com/account>
+
+=item service
+
+Name of the Google service for which authorization is requested such as 'cl' for Calendar.
+
+Defaults to 'xapi' for calendar.
+
+=item source
+
+Short string identifying your application, for logging purposes.
+
+Defaults to 'Net::Google::AuthSub-<VERSION>'
+
+=item accountType
+
+Type of account to be authenticated.
+
+Defaults to 'HOSTED_OR_GOOGLE'.
+
+=back
+
+See http://code.google.com/apis/accounts/AuthForInstalledApps.html#ClientLogin for more details.
+
+=cut
+
+
+our %BUGS = (
+    'not_dopplr_any_more' => {
+        'cuddled'       => 1,
+        'json_response' => 1,
+    },
+);
+
+sub new {
+    my $class  = shift;
+    my %params = @_;
+
+    $params{_ua}           = LWP::UserAgent->new;    
+    $params{_ua}->env_proxy;
+    $params{url}         ||= 'https://www.google.com/accounts';
+    $params{service}     ||= 'xapi';
+    $params{source}      ||= $APP_NAME;
+    $params{accountType} ||= 'HOSTED_OR_GOOGLE';
+    $params{_compat}     ||= {};
+
+    my $site = delete $params{_bug_compat};
+    if (defined $site && exists $BUGS{$site}) {
+        foreach my $key (keys %{$BUGS{$site}}) {
+            $params{_compat}->{$key} = $BUGS{$site}->{$key};
+        }
+    }
+
+
+    return bless \%params, $class;
+}
+
+=head2 login <username> <password> [opt[s]]
+
+Login to google using your username and password.
+
+Can optionally take a hash of options which will override the 
+default login params. 
+
+Returns a C<Net::Google::AuthSub::Response> object.
+
+=cut
+
+sub login {
+    my ($self, $user, $pass, %opts) = @_;
+
+    # setup auth request
+    my %params = ( Email       => $user, 
+                   Passwd      => $pass, 
+                   service     => $self->{service}, 
+                   source      => $self->{source},
+                   accountType => $self->{accountType} );
+    # allow overrides
+    $params{$_} = $opts{$_} for (keys %opts);
+
+
+    my $uri = URI->new($self->{url});
+    $uri->path($uri->path.'/ClientLogin');
+    my $tmp = $self->{_ua}->request(POST "$uri", [ %params ]);
+    return $self->_response_failure($tmp) unless $tmp->is_success;
+    my $r = Net::Google::AuthSub::Response->new($tmp, $self->{url}, _compat => $self->{_compat});
+
+
+    # store auth token
+    $self->{_auth}      = $r->auth;
+    $self->{_auth_type} = CLIENT_LOGIN;
+    $self->{user}       = $user;
+    $self->{pass}       = $pass; 
+    return $r;
+
+}
+
+sub _response_failure {
+    my $self = shift;
+    my $r    = shift;
+    $@ = $r->content;
+    return undef;
+}
+
+
+=head2 authorised 
+
+Whether or not we're authorised.
+
+=cut
+
+sub authorised {
+    my $self = shift;
+    return defined $self->{_auth};
+
+}
+
+=head2 auth <username> <token>
+
+Use the AuthSub method for access.
+
+See http://code.google.com/apis/accounts/AuthForWebApps.html 
+for details.
+
+=cut
+
+sub auth {
+    my ($self, $username, $token) = @_;
+    $self->{_auth}      = $token;
+    $self->{_auth_type} = AUTH_SUB;
+    $self->{user}       = $username;
+    return 1;
+}
+
+
+
+=head2 request_token <next> <scope> [option[s]]
+
+Return a URI object representing the URL which the user 
+should be directed to in order to aquire a single use token.
+
+The parameters are 
+
+=over 4
+
+=item next (required)
+
+URL the user should be redirected to after a successful login. 
+This value should be a page on the web application site, and 
+can include query parameters.
+
+=item scope (required)
+
+URL identifying the service to be accessed. The resulting token 
+will enable access to the specified service only. Some services 
+may limit scope further, such as read-only access.
+
+For example
+
+    http://www.google.com/calendar/feed
+
+=item secure
+
+Boolean flag indicating whether the authentication transaction 
+should issue a secure token (1) or a non-secure token (0). 
+Secure tokens are available to registered applications only.
+
+=item session
+
+Boolean flag indicating whether the one-time-use token may be 
+exchanged for a session token (1) or not (0).
+
+=back
+
+=cut
+
+sub request_token {
+    my $self = shift;
+    my ($next, $scope, %opts) = @_;
+    $opts{next}  = $next;
+    $opts{scope} = $scope;
+
+    my $uri = URI->new($self->{url});
+
+    $uri->path($uri->path.'/AuthSubRequest');
+    $uri->query_form(%opts);
+    return $uri;
+}
+
+
+=head2 session_token
+
+Exchange the temporary token for a long-lived session token.
+
+The single-use token is acquired by visiting the url generated by
+calling request_token.
+
+Returns the token if success and undef if failure.
+
+=cut
+
+sub session_token {
+    my $self = shift;
+
+    my $uri = URI->new($self->{url});
+    $uri->path($uri->path.'/AuthSubSessionToken');
+
+    my %params = $self->auth_params();
+    my $tmp    = $self->{_ua}->request(GET "$uri", %params);
+    return $self->_response_failure($tmp) unless $tmp->is_success;    
+    my $r      = Net::Google::AuthSub::Response->new($tmp, $self->{url}, _compat => $self->{_compat});
+
+    # store auth token
+    $self->{_auth}      = $r->token;
+    
+    return $r->token;
+}
+
+=head2 revoke_token
+
+Revoke a valid session token. Session tokens have no expiration date and 
+will remain valid unless revoked.
+
+Returns 1 if success and undef if failure.
+
+=cut
+
+sub revoke_token {
+    my $self = shift;
+
+    my $uri = URI->new($self->{url});
+    $uri->path($uri->path.'/AuthSubRevokeToken');
+
+    my %params = $self->auth_params();
+    my $r      = $self->{_ua}->request(GET "$uri", [ %params ]);
+    return $self->_response_error($r) unless $r->is_success;
+    return 1;
+
+}
+
+=head2 token_info
+
+Call AuthSubTokenInfo to test whether a given session token is valid. 
+This method validates the token in the same way that a Google service 
+would; application developers can use this method to verify that their 
+application is getting valid tokens and handling them appropriately 
+without involving a call to the Google service. It can also be used to 
+get information about the token, including next URL, scope, and secure 
+status, as specified in the original token request.
+
+Returns a C<Net::Google::AuthSub::Response> object on success or undef on failure.
+
+=cut
+
+sub token_info {
+    my $self = shift;
+
+    my $uri = URI->new($self->{url});
+    $uri->path($uri->path.'/AuthSubTokenInfo');
+
+    my %params = $self->auth_params();
+    my $tmp    = $self->{_ua}->request(GET "$uri", [ %params ]);
+    my $r      = Net::Google::AuthSub::Response->new($tmp, $self->{url}, _compat => $self->{_compat});    
+    return $self->_response_failure($r) unless $r->is_success;
+    return $r;
+} 
+
+=head2 auth_params
+
+Return any parameters needed in an HTTP request to authorise your app.
+
+=cut
+
+sub auth_params {
+    my $self  = shift;
+
+    return () unless $self->authorised;
+    return ( Authorization => $self->_auth_string );
+}
+
+my %AUTH_TYPES = ( CLIENT_LOGIN() => "GoogleLogin auth", AUTH_SUB() => "AuthSub token" );
+
+sub _auth_string {
+    my $self   = shift;
+    return "" unless $self->authorised;
+    if ($self->{_compat}->{uncuddled_auth}) {
+        return sprintf '%s=%s', $AUTH_TYPES{$self->{_auth_type}}, $self->{_auth};
+    } else {
+        return sprintf '%s="%s"', $AUTH_TYPES{$self->{_auth_type}}, $self->{_auth};        
+    }
+}
+
+
+=head1 AUTHOR
+
+Simon Wistow <simon at thegestalt.org>
+
+=head1 COPYRIGHT
+
+Copyright, 2007 - Simon Wistow
+
+Released under the same terms as Perl itself
+
+=cut
+
+
+1;

Added: branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub/Response.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub/Response.pm?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub/Response.pm (added)
+++ branches/upstream/libnet-google-authsub-perl/current/lib/Net/Google/AuthSub/Response.pm Mon May  4 06:17:14 2009
@@ -1,0 +1,175 @@
+package Net::Google::AuthSub::Response;
+
+use strict;
+our $AUTOLOAD;
+
+=head1 NAME
+
+Net::Google::AuthSub::Response - a response from a Net::Google::AuthSub request
+
+=head1 SYNOPSIS
+
+    my $response = $auth->login($user, $pass);
+    
+    if ($response->is_success) {
+        print "Yay!\n";
+    } else {
+        if ($response->error eq 'CaptchaRequired') {
+            print "Captcha Image ".$response->captchaurl;
+        }
+    }
+
+=head1 METHODS
+
+=cut
+
+=head2 new C<HTTP::Response> C<base url>
+
+Create a new response.
+
+=cut
+
+sub new {
+    my ($class, $response, $url, %opts) = @_;
+
+    
+    my %values;
+    if ($opts{_compat}->{json_response}) {
+        eval 'use JSON::Any';
+        die "You need to install JSON::Any to use JSON responses" if $@;
+        %values = %{JSON::Any->from_json($response->content)};
+    } else {
+        foreach my $line (split /\n/, $response->content) {
+            chomp($line);
+            my ($key, $value) = split '=', $line;
+            $values{lc($key)} = $value;
+        }
+    }    
+
+    return bless { _response => $response, _values => \%values, _url => $url }, $class;
+
+}
+
+
+=head2 is_success 
+
+Returns whether the response was a sucess or not.
+
+=cut
+
+sub is_success {
+    my $self = shift;
+    return $self->{_response}->is_success;
+}
+
+=head1 SUCCESS METHODS
+
+Methods available if the response was a success.
+
+=head2 auth
+
+The authorisation token if the response is a success.
+
+=head2 sid
+
+Not used yet.
+
+=head2 lsid
+
+Not used yet.
+
+
+=head1 ERROR METHODS
+
+Methods available if the response was an error.
+
+=head2 error
+
+The error code. Can be one of
+
+=over 4
+
+=item BadAuthentication     
+
+The login request used a username or password that is not recognized.
+
+=item NotVerified     
+
+The account email address has not been verified. The user will need to 
+access their Google account directly to resolve the issue before logging 
+in using a non-Google application.
+
+=item TermsNotAgreed     
+
+The user has not agreed to terms. The user will need to access their 
+Google account directly to resolve the issue before logging in using a 
+non-Google application.
+
+=item CaptchaRequired     
+
+A CAPTCHA is required. (A response with this error code will also 
+contain an image URL and a CAPTCHA token.)
+
+=item Unknown     
+
+The error is unknown or unspecified; the request contained invalid input 
+or was malformed.
+
+=item AccountDeleted     
+
+The user account has been deleted.
+
+=item AccountDisabled     
+
+The user account has been disabled.
+
+=item ServiceDisabled     
+
+The user's access to the specified service has been disabled. (The user 
+account may still be valid.)
+
+=item ServiceUnavailable     
+
+The service is not available; try again later.
+
+=back
+
+=head2 url
+
+The url of a page describing the error.
+
+=head2 captchatoken
+
+The token required to authenticate a captcha.
+
+=head2 captchaurl
+
+The full url of the captcha image.
+
+=cut
+
+sub captchaurl {
+    my $self = shift;
+    my $url  = $self->{_values}->{captchaurl};
+    return $self->{url}."/accounts/$url";
+}
+
+sub AUTOLOAD {
+    my $self = shift;
+
+    my $type = ref($self)
+            or die "$self is not an object";
+
+    my $name = $AUTOLOAD;
+    $name =~ s/.*://;   # strip fully-qualified portion
+
+    if (@_) {
+        return $self->{_values}->{$name} = shift;
+    } else {
+        return $self->{_values}->{$name};
+    }
+}
+
+sub DESTROY {}  
+
+1;

Added: branches/upstream/libnet-google-authsub-perl/current/t/00use.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/t/00use.t?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/t/00use.t (added)
+++ branches/upstream/libnet-google-authsub-perl/current/t/00use.t Mon May  4 06:17:14 2009
@@ -1,0 +1,7 @@
+#!perl -w
+
+use strict;
+use Test::More tests => 2;
+
+use_ok("Net::Google::AuthSub::Response");
+use_ok("Net::Google::AuthSub");

Added: branches/upstream/libnet-google-authsub-perl/current/t/pod-coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/t/pod-coverage.t?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/t/pod-coverage.t (added)
+++ branches/upstream/libnet-google-authsub-perl/current/t/pod-coverage.t Mon May  4 06:17:14 2009
@@ -1,0 +1,8 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+eval 'use Test::Pod::Coverage 1.04';
+plan skip_all => 'Test::Pod::Coverage 1.04 required for testing POD coverage' if $@;
+all_pod_coverage_ok();

Added: branches/upstream/libnet-google-authsub-perl/current/t/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libnet-google-authsub-perl/current/t/pod.t?rev=34709&op=file
==============================================================================
--- branches/upstream/libnet-google-authsub-perl/current/t/pod.t (added)
+++ branches/upstream/libnet-google-authsub-perl/current/t/pod.t Mon May  4 06:17:14 2009
@@ -1,0 +1,9 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More;
+eval 'use Test::Pod 1.14';
+plan skip_all => 'Test::Pod 1.14 required for testing POD' if $@;
+all_pod_files_ok();




More information about the Pkg-perl-cvs-commits mailing list