File Coverage

blib/lib/URI/otpauth.pm

Criterion	Covered	Total	%
statement	95	96	98.9
branch	23	24	95.8
condition	2	3	66.6
subroutine	22	22	100.0
pod	11	11	100.0
total	153	156	98.0

package URI::otpauth;

use warnings;
use strict;
use MIME::Base32();
use URI::Split();
use URI::Escape();

use parent qw( URI URI::_query );

our $VERSION = '5.34';

sub new {
    my ($class, @parameters) = @_;
    my %fields = $class->_set(@parameters);
    my $uri    = URI::Split::uri_join(
        'otpauth', $fields{type},
        $class->_path(%fields),
        $class->_query(%fields),
    );
    return bless \$uri, $class;
}

sub _parse {
    my $self = shift;
    my ($scheme, $type, $path, $query, $frag) = URI::Split::uri_split(${$self});
    $path =~ s/^\///smxg;
    my @path_parts = split /:/smx, $path;
    my ($issuer_prefix, $account_name);
    if (scalar @path_parts == 1) {
        $account_name = $path_parts[0];
    }
    else {
        $issuer_prefix = $path_parts[0];
        $account_name  = $path_parts[1];
    }
    my %fields = (label => $path, type => $type, account_name => $account_name);
    my $issuer_parameter = $self->query_param('issuer');
    if (defined $issuer_parameter) {
        if ((defined $issuer_prefix) && ($issuer_prefix ne $issuer_parameter)) {
            Carp::carp(
                "Issuer prefix from label '$issuer_prefix' does not match issuer parameter '$issuer_parameter'"
            );
        }
        $fields{issuer} = $issuer_parameter;
    }
    elsif (defined $issuer_prefix) {
        $fields{issuer} = URI::Escape::uri_unescape($issuer_prefix);
    }
    if (my $encoded_secret = $self->query_param('secret')) {
        $fields{secret} = MIME::Base32::decode_base32($encoded_secret);
    }
    foreach my $name (qw(algorithm digits counter period)) {
        if (my $value = $self->query_param($name)) {
            $fields{$name} = $value;
        }
    }
    %fields = $self->_set(%fields);
    return ($scheme, $fields{type}, \%fields, $query, $frag);
}

my $label_escape_regex = qr/[^[:alnum:]@.]/smx;

sub _set {
    my ($self, %fields) = @_;
    delete $fields{label};
    if (defined $fields{account_name}) {
        if (defined $fields{issuer}) {
            $fields{label} = $fields{issuer} . q[:] . $fields{account_name};
        }
        else {
            $fields{label} = $fields{account_name};
        }
    }
    if (!length $fields{type}) {
        $fields{type} = 'totp';
    }
    return %fields;
}

my %field_names = map { $_ => 1 }
    qw(secret label counter algorithm period digits issuer type account_name);
my @query_names = qw(secret issuer algorithm digits counter period);
my %defaults = (algorithm => 'SHA1', digits => 6, type => 'totp', period => 30);

sub _field {
    my ($self, $name, @remainder) = @_;
    my ($scheme, $type, $fields, $query, $frag) = $self->_parse();

    if (!@remainder) {
        if (defined $fields->{$name}) {
            return $fields->{$name};
        }
        else {
            return $defaults{$name};
        }
    }
    $fields->{$name} = shift @remainder;
    ${$self} = URI::Split::uri_join(
        $scheme, $fields->{type},
        $self->_path(%{$fields}),
        $self->_query(%{$fields}), $frag
    );
    return $self;
}

sub _query {
    my ($class, %fields) = @_;
    if (defined $fields{secret}) {
        $fields{secret} = MIME::Base32::encode_base32($fields{secret});
    }
    else {
        Carp::croak('secret is a mandatory parameter for ' . __PACKAGE__);
    }
    return join q[&],
        map { join q[=], $_ => $fields{$_} }
        grep { exists $fields{$_} } @query_names;
}

sub _path {
    my ($class, %fields) = @_;
    my $path = $fields{label};
    return $path;
}

sub type {
    my ($self, @parameters) = @_;
    return $self->_field('type', @parameters);
}

sub authority { return shift->type(@_); }

sub label {
    my ($self, @parameters) = @_;
    return $self->_field('label', @parameters);
}

sub account_name {
    my ($self, @parameters) = @_;
    return $self->_field('account_name', @parameters);
}

sub issuer {
    my ($self, @parameters) = @_;
    return $self->_field('issuer', @parameters);
}

sub secret {
    my ($self, @parameters) = @_;
    return $self->_field('secret', @parameters);
}

sub algorithm {
    my ($self, @parameters) = @_;
    return $self->_field('algorithm', @parameters);
}

sub counter {
    my ($self, @parameters) = @_;
    return $self->_field('counter', @parameters);
}

sub digits {
    my ($self, @parameters) = @_;
    return $self->_field('digits', @parameters);
}

sub period {
    my ($self, @parameters) = @_;
    return $self->_field('period', @parameters);
}

1;

__END__