File Coverage

blib/lib/Config/Identity.pm

Criterion	Covered	Total	%
statement	96	99	96.9
branch	34	48	70.8
condition	8	13	61.5
subroutine	16	16	100.0
pod	2	10	20.0
total	156	186	83.8

use strict;
use warnings;

package Config::Identity;
# ABSTRACT: Load (and optionally decrypt via GnuPG) user/pass identity information

our $VERSION = '0.0019';

use Carp;
use IPC::Run qw/ start finish /;
use File::HomeDir();
use File::Spec;

our $home = File::HomeDir->home;
{
    my $gpg;
    sub GPG() { $ENV{CI_GPG} || ( $gpg ||= do {
        require File::Which;
        $gpg = File::Which::which( $_ ) and last for qw/ gpg gpg2 /;
        $gpg;
    } ) }
}
sub GPG_ARGUMENTS() { $ENV{CI_GPG_ARGUMENTS} || '' }

# TODO Do not even need to do this, since the file is on disk already...
sub decrypt {
    my $self = shift;
    my $file = shift;

    my $gpg = GPG or croak "Missing gpg";
    my $gpg_arguments = GPG_ARGUMENTS;
    my $run;
    # Old versions, please ignore
    #$run = "$gpg $gpg_arguments -qd --no-tty --command-fd 0 --status-fd 1";
    #$run = "$gpg $gpg_arguments -qd --no-tty --command-fd 0";
    $run = "$gpg $gpg_arguments -qd --no-tty";
    my @run = split m/\s+/, $run;
    push @run, $file;
    my $process = start( \@run, '>pipe', \*OUT, '2>pipe', \*ERR );
    my $output = join '', ;
    my $_error = join '', ;
    finish $process;
    return ( $output, $_error );
}

sub best {
    my $self = shift;
    my $stub = shift;
    my $base = shift;
    $base = $home unless defined $base;

    croak "Missing stub" unless defined $stub && length $stub;

    for my $i0 ( ".$stub-identity", ".$stub" ) {
        for my $i1 ( "." ) {
            my $path = File::Spec->catfile( $base, $i1, $i0 );
            return $path if -f $path;
        }
    }

    return '';
}

sub read {
    my $self = shift;
    my $file = shift;

    croak "Missing file" unless -f $file;
    croak "Cannot read file ($file)" unless -r $file;

    my $binary = -B $file;

    open my $handle, $file or croak $!;
    binmode $handle if $binary;
    local $/ = undef;
    my $content = <$handle>;
    close $handle or warn $!;

    if ( $binary || $content =~ m/----BEGIN PGP MESSAGE----/ ) {
        my ( $_content, $error ) = $self->decrypt( $file );
        if ( $error ) {
            carp "Error during decryption of content" . $binary ? '' : "\n$content";
            croak "Error during decryption of $file:\n$error";
        }
        $content = $_content;
    }

    return $content;
}

sub parse {
    my $self = shift;
    my $content = shift;

    return unless $content;
    my %content;
    for ( split m/\n/, $content ) {
        next if /^\s*#/;
        next unless m/\S/;
        next unless my ($key, $value) = /^\s*(\w+)\s+(.+)$/;
        $content{$key} = $value;
    }
    return %content;
}

sub load_best {
    my $self = shift;
    my $stub = shift;

    croak "Unable to find .$stub-identity or .$stub" unless my $path = $self->best( $stub );
    return $self->load( $path );
}

sub try_best {
    my $self = shift;
    my $stub = shift;

    return unless my $path = $self->best( $stub );
    return $self->load( $path );
}

sub load {
    my $self = shift;
    my $file = shift;

    return $self->parse( $self->read( $file ) );
}

sub load_check {
    my $self = shift;
    my $stub = shift;
    my $required = shift || [];

    my %identity = $self->load_best($stub);
    my @missing;
    if ( ref $required eq 'ARRAY' ) {
        @missing = grep { ! defined $identity{$_} } @$required;
    }
    elsif ( ref $required eq 'CODE' ) {
        local $_ = \%identity;
        @missing = $required->(\%identity);
    }
    else {
        croak "Argument to check keys must be an arrayref or coderef";
    }

    if ( @missing ) {
        my $inflect = @missing > 1 ? "fields" : "field";
        croak "Missing required ${inflect}: @missing"
    }

    return %identity;
}

1;

__END__