File Coverage

blib/lib/Web/MicroID.pm

Criterion	Covered	Total	%
statement	77	77	100.0
branch	19	24	79.1
condition	6	7	85.7
subroutine	17	17	100.0
pod	11	11	100.0
total	130	136	95.5

package Web::MicroID;

use 5.008008;
use strict;
use warnings;
use Carp;
use Digest::SHA1;
use Digest::MD5;

our $VERSION = '0.02';

=pod

=head1 NAME

Web::MicroID - An implementation of the MicroID standard

=head1 VERSION

This documentation refers to Web::MicroID version 0.02

=head1 SYNOPSIS

    use Web::MicroID;

    $id = Web::MicroID->new();

    $id->individual('mailto:[e-mail]');
    $id->serv_prov('http://domain.tld/');

=cut

sub individual {
    my $self = shift;
    my $id   = shift;

    if ($id) {
        croak 'individual() not in the correct format' unless $id =~/:/;

        # Set ID, split it into parts and set them too
        $self->[0]->{individual} = $id;
        (
            $self->[0]->{indv_uri}, $self->[0]->{indv_val}
        ) = split /\:\/*/, $id;
    }

    # Get any ID we may have
    return $self->[0]->{individual};
}
sub indv_uri {
    my $self = shift;

    # Get the URI of any ID we may have
    return $self->[0]->{indv_uri};
}
sub indv_val {
    my $self = shift;

    # Get the URI value of any ID we may have
    return $self->[0]->{indv_val};
}
sub serv_prov {
    my $self = shift;
    my $id   = shift;

    if ($id) {
        croak 'serv_prov() not in the correct format' unless $id =~/:/;

        # Set ID, split it into parts and set them too
        $self->[0]->{serv_prov} = $id;
        (
            $self->[0]->{serv_prov_uri}, $self->[0]->{serv_prov_val}
        ) = split /\:\/*/, $id;
        $self->[0]->{serv_prov_val} =~ s/\/$//;
    }

    # Get any ID we may have
    return $self->[0]->{serv_prov};
}
sub serv_prov_uri {
    my $self = shift;

    # Get the URI of any ID we may have
    return $self->[0]->{serv_prov_uri};
}
sub serv_prov_val {
    my $self = shift;

    # Get the URI value of any ID we may have
    return $self->[0]->{serv_prov_val};
}
sub algorithm {
    my $self = shift;
    my $id   = shift;

    # Change the algorithm if a new one is provided
    $self->[0]->{algorithm} = $id || 'sha1';

    # Get the alogorithm we're using
    return $self->[0]->{algorithm};
}

=pod

    # Generate a MicroID token
    $micro_id = $id->generate();

=cut

sub generate {
    my $self = shift;
    my $id   = $self->[0];

    # Check state
    croak 'Must set individual() before calling generate()'
        unless $id->{individual};
    croak 'Must set serv_prov() before calling generate()'
        unless $id->{serv_prov};
    individual($self, $id->{individual}) unless $id->{indv_uri};
    serv_prov($self,  $id->{serv_prov})  unless $id->{serv_prov_uri};
    algorithm($self)                     unless $id->{algorithm};

    # Call the correct algorithm constructor
    my $algor;
    if ($id->{algorithm} eq 'md5')  {$algor = Digest::MD5->new}
    else {$algor = Digest::SHA1->new}

    # Hash the ID's
    my $indv = $algor->add($id->{individual})->hexdigest;
    $algor->reset;
    my $serv = $algor->add($id->{serv_prov} )->hexdigest;
    $algor->reset;

    # Hash the ID's together and set as the legacy MicroID token
    $self->[0]->{legacy} = $algor->add($indv . $serv)->hexdigest;

    # Assemble the MicroID token and set it
    my $micro_id = join ':', (
        $id->{indv_uri} . '+' . $id->{serv_prov_uri},
        $id->{algorithm},
        $self->[0]->{legacy}
    );
    $self->[0]->{micro_id} = $micro_id;

    # Get the MicroID token
    return $micro_id;
}
sub legacy {
    my $self = shift;

    # Get any legacy MicroID token
    return $self->[0]->{legacy};
}

=pod

    # Process (validate) a MicroID token
    $test = $id->process($micro_id);

=cut

sub process {
    my $self   = shift;
    my $process = shift || $self->[0]->{process};

    croak 'Must set process() before calling process()' unless $process;

    my @verify = split /:/, $process;
    generate($self);
    return 1 if pop @verify eq $self->[0]->{legacy};
    return;
}
sub new {
    my $class = shift;
    my $conf  = shift || {};
    my $self  = bless [$conf], $class;
    return $self;
}

__END__