#!/usr/bin/perl -Tw
################################################################################
package WWW::Yahoo::Credentials;
# $Id: Credentials.pm,v 1.2 2005/10/09 23:08:21 ken Exp $

=pod

=head1 NAME

WWW::Yahoo::Credentials - personal storage of userid/password/security_key

=head1 SYNOPSIS

  require WWW::Yahoo::Credentials;
  my $credentials = new WWW::Yahoo::Credentials;
  my $password = $credentials->password( $userid );
  my( $userid, $password ) = $credentials->tuple;

=head1 DESCRIPTION

This module provides access methods to credentials stored in an XML
file.  The format of this file is as shown in this example:

  <?xml version="1.0" encoding="UTF-8" standalone="yes"?>
  <credentials>
    <account userid="userid1" password="password1"/>
    <account userid="userid2" password="password2"/>
    <account userid="userid3" password="password3" security-key="key3"/>
  </credential>

Note that this module does not perform an actual XML parse of the
credentials file.  Instead, it simply performs a regular expression
pattern match for the 'account' tag, and searches for the three
attributes listed above.

When used in a string context, this object will return the filename,
for example,

  print "Loaded credentials file '$credentials'\n";

Errors may be caught using "eval", for example,

  my( $credentials, $userid, $password );
  eval {
      $credentials = new WWW::Yahoo::Credentials;
      ( $userid, $password ) = $credentials->tuple;
  };
  if ( $@ ) {
      die ucfirst( $@->description ) . ": $@";
  }
  elsif ( not defined $userid ) {
      die "File error: userid not found in credentials file: $credentials\n";
  }

See
L<WWW::Yahoo::Credentials::Exceptions|WWW::Yahoo::Credentials::Exceptions>
for a list of exceptions (they are thrown using the
L<Exception::Class|Exception::Class> module).

=head1 METHODS

=cut

################################################################################
use 5.006;
use strict;
use warnings;
use File::stat ();
use IO::File;
require WWW::Yahoo::Credentials::File;
require WWW::Yahoo::Credentials::Exceptions;
use overload '""' => sub { $_[0]->file },
  'cmp' => sub { "$_[0]" cmp "$_[1]" };

our $VERSION = '0.80';

################################################################################

=pod

=head2 new

  my $credentials = new WWW::Yahoo::Credentials;
  my $credentials = WWW::Yahoo::Credentials->new( '~/.yahoo/credentials.xml' );
  my $credentials = WWW::Yahoo::Credentials->new( %options );

This creates a new object representing the credentials stored in an
XML file.  The default location of this file is
"~/.yahoo/credentials.xml", but the location can be specified using
the various options described in the
L<new|WWW::Yahoo::Credentials::File/new> method of
L<WWW::Yahoo::Credentials::File|WWW::Yahoo::Credentials::File>.

=cut

#-------------------------------------------------------------------------------
sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->{file} = ''; # to preclude undef warnings when bad args are given
    @_ ? $self->file( @_ ) : $self->file( undef );
    $self;
}

################################################################################

=pod

=head2 file

  my $file = $credentials->file;
  my $oldfile = $credentials->file( $newfile );
  my $oldfile = $credentials->file( undef ); # use default location
  my $oldfile = $credentials->file( %options );

Returns current file object
(L<WWW::Yahoo::Credentials::File|WWW::Yahoo::Credentials::File>) or
reads a new credentials file.  The location of the new file can be
specified using the various options described in the
L<new|WWW::Yahoo::Credentials::File/new> method of
L<WWW::Yahoo::Credentials::File|WWW::Yahoo::Credentials::File>.

=cut

#-------------------------------------------------------------------------------
sub file {
    my $self = shift;

    my $oldfile = $self->{file};
    if ( @_ ) {
	$self->{file} = WWW::Yahoo::Credentials::File->new( @_ );
	delete $self->{mtime};
	$self->refresh;
    }
    $oldfile;
}

################################################################################

=pod

=head2 userids

  my @userids = $credentials->userids;

Returns a list of all userids defined in the credentials file.

=cut

#-------------------------------------------------------------------------------
sub userids {
    my $self = shift;

    $self->refresh;
    @{$self->{userids}};
}

################################################################################

=pod

=head2 password

  my $password = $credentials->password( $userid );

Returns the password for the given userid.  The userid is looked up in
a case-insensitive manner.

Note: do not confuse the Yahoo userid with your local username.

=cut

#-------------------------------------------------------------------------------
sub password {
    my $self = shift;
    my $userid = shift;
    return unless defined $userid;
    $self->{password}->{ lc $userid };
}

################################################################################

=pod

=head2 security_key

  my $security_key = $credentials->security_key( $userid );

Returns the security_key for the given userid.  The userid is looked
up in a case-insensitive manner.

Note: do not confuse the Yahoo userid with your local username.

=cut

#-------------------------------------------------------------------------------
sub security_key {
    my $self = shift;
    my $userid = shift;
    return unless defined $userid;
    $self->{security_key}->{ lc $userid };
}

################################################################################

=pod

=head2 tuple

  my( $userid, $password, $security_key ) = $credentials->tuple;
  my( $userid, $password, $security_key ) = $credentials->tuple( $userid );

Returns the userid, password, and security_key for a given userid (or
for the first userid if none is defined).  The userid is looked up in
a case-insensitive manner.

=cut

#-------------------------------------------------------------------------------
sub tuple {
    my $self = shift;
    my $userid = shift;

    $self->refresh;
    $userid = $self->{userids}->[0] unless defined $userid;
    return unless defined $userid;
    my $lc_userid = lc $userid;
    (
     $self->{userid}->{$lc_userid},
     $self->{password}->{$lc_userid},
     $self->{security_key}->{$lc_userid},
    );
}

################################################################################

=pod

=head2 refresh

  my $refreshed = $credentials->refresh;

Checks to see if the date of the credentials file has changed since it
was last read.  If so, re-reads it.  This method is automatically
called by the other methods.

=cut

#-------------------------------------------------------------------------------
sub refresh {
    my $self = shift;

    unless ( -e $self->{file} ) {
	my $error = "credentials file does not exist: $self->{file}";
	WWW::Yahoo::Credentials::Exception::File->throw( $error );
    }
    my $stat = File::stat::stat( $self->{file} );
    unless ( $stat ) {
	my $error = "could not stat credentials file: $self->{file}: $!";
	WWW::Yahoo::Credentials::Exception::File->throw( $error );
    }
    my $mtime = $stat->mtime;
    return if defined $self->{mtime} and $self->{mtime} == $mtime;

    my $fh = IO::File->new( $self->{file}, O_RDONLY );
    unless ( $fh ) {
	my $error = "could not open credentials file: $self->{file}: $!";
	WWW::Yahoo::Credentials::Exception::File->throw( $error );
    }
    my $xml = do { local $/; <$fh> }; # slurp file
    unless ( $fh->close ) {
	my $error = "could not close credentials file: $self->{file}: $!";
	WWW::Yahoo::Credentials::Exception::File->throw( $error );
    }

    $self->{mtime} = $mtime;
    $self->{userids} = [];
    $self->{userid} = {};
    $self->{password} = {};
    $self->{security_key} = {};

    my $lineno = 1;
    while ( $xml =~ m!(.*?)<account\s+([^>]*)>!gs ) {
	my( $prematch, $attributes ) = ( $1, $2 );
	++$lineno while $prematch =~ m!\n!g;
	my( $userid ) =
	  $attributes =~ m!(?:^|\s)userid=(?:"([^\"]*)"|'([^\']*)')!;
	my( $password) =
	  $attributes =~ m!(?:^|\s)password=(?:"([^\"]*)"|'([^\']*)')!;
	my( $security_key ) =
	  $attributes =~ m!(?:^|\s)security-key=(?:"([^\"]*)"|'([^\']*)')!;
	unless ( defined $userid ) {
	    my $error = "userid not defined on line $lineno" .
	      " of credentials file: $self->{file}";
	    WWW::Yahoo::Credentials::Exception::Syntax->throw( $error );
	}
	my $lc_userid = lc $userid;
	if ( exists $self->{userid}->{$lc_userid} ) {
	    my $error = "userid defined again on line $lineno" .
	      " of credentials file: $self->{file}";
	    WWW::Yahoo::Credentials::Exception::Syntax->throw( $error );
	}
	push( @{$self->{userids}}, $userid );
	$self->{userid}->{$lc_userid} = $userid;
	$self->{password}->{$lc_userid} = $password;
	$self->{security_key}->{$lc_userid} = $security_key;
    }

    1;
}

################################################################################

=pod

=head1 SEE ALSO

L<WWW::Yahoo::Credentials::File|WWW::Yahoo::Credentials::File>,
L<WWW::Yahoo::Credentials::Exceptions|WWW::Yahoo::Credentials::Exceptions>,
L<Exception::Class|Exception::Class>

=head1 AUTHOR

Ken Neighbors, Ph.D.
ken@nsds.com

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Ken Neighbors

This module is free software; you can redistribute it and/or modify it
under the same terms as Perl itself, either Perl version 5.000 or (at
your option) any later version of Perl.  That is, you can redistribute
this module and/or modify it under the terms of either:

  a) the GNU General Public License as published by the Free Software
     Foundation; either version 1, or (at your option) any later version,
     or

  b) the "Artistic License" which comes with Perl, or

  c) the license terms of Perl versions later than 5.000

=cut

1;
