view release on metacpan or  search on metacpan

lib/App/Dochazka/CLI/Util.pm  view on Meta::CPAN

   }

   return \@datelist;
}


=head2 determine_employee

Given what might possibly be an employee specification (as obtained from the
user from the EMPLOYEE_SPEC token of the command line), return a status object
that will either be an error (not OK) or contain the employee object in the
payload.

If the employee specification is empty or undefined, the payload will contain
the C<$current_emp> object.

=cut

sub determine_employee {
    my $s_key = shift;
    $log->debug( "Entering " . __PACKAGE__ . "::determine_employee with \$s_key ->" .
        ( defined( $s_key ) ? $s_key : "undef" ) . "<-" );

    my $status = ( $s_key )
        ? lookup_employee( key => $s_key, minimal => 1 )
        : refresh_current_emp();
    return ( $status->ok )
        ? $CELL->status_ok( 'EMPLOYEE_LOOKUP', 
            payload => App::Dochazka::Common::Model::Employee->spawn( %{ $status->payload } ) )
        : rest_error( $status, "Employee lookup" );
}


=head2 lookup_employee

EMPLOYEE_SPEC may be "nick=...", "sec_id=...", "eid=...", or simply
"employee=...", in which case we use a clever algorithm to look up employees
(i.e. try looking up search key as nick, sec_id, and EID - in that order).

=cut

sub lookup_employee {
    my %ARGS = validate( @_, 
        {
            key => { type => SCALAR },
            minimal => { default => 0 },     
        }
    );
    print "Entering " . __PACKAGE__ . "::lookup_employee with search key " . Dumper( $ARGS{key} )
        if $debug_mode;

    die( "AH! Not an EMPLOYEE_SPEC" ) unless $ARGS{key} =~ m/=/;

    my ( $key_spec, $key ) = $ARGS{key} =~ m/^(.*)\=(.*)$/;
    my $minimal = $ARGS{minimal} ? '/minimal' : '';

    my $status;
    if ( $key_spec =~ m/^emp/i ) {
        $status = send_req( 'GET', "employee/nick/$key$minimal" );
        BREAK_OUT: {
            last BREAK_OUT if $status->not_ok and $status->payload and $status->payload->{'http_code'} == 403;
            if ( $status->not_ok and $status->payload and $status->payload->{'http_code'} == 404 ) {
                $status = send_req( 'GET', "employee/sec_id/$key$minimal" );
                if ( $status->not_ok and $status->payload and $status->payload->{'http_code'} != 500 and looks_like_number( $key ) ) {
                    $status = send_req( 'GET', "employee/eid/$key$minimal" );
                }
            }
        }
    } elsif ( $key_spec =~ m/^nic/i ) {
        $status = send_req( 'GET', "employee/nick/$key$minimal" );
    } elsif ( $key_spec =~ m/^sec/i ) {
        $status = send_req( 'GET', "employee/sec_id/$key$minimal" );
    } elsif ( $key_spec =~ m/^eid/i ) {
        $status = send_req( 'GET', "employee/eid/$key$minimal" );
    } else {
        die "AAAHAAAHHH!!! Invalid employee lookup key " . ( defined( $key_spec ) ? $key_spec : "undefined" )
    }

    return $status;
}


=head2 init_logger

Logger initialization routine

=cut

sub init_logger {
    my $log_file = normalize_filespec( $site->DOCHAZKA_CLI_LOG_FILE );
    unlink $log_file if $site->DOCHAZKA_CLI_LOG_FILE_RESET;
    print "Logging to $log_file\n";
    Log::Any::Adapter->set('File', $log_file );
    $log->init( ident => 'dochazka-cli', debug_mode => 1 );
    $log->debug( 'Logger initialized' );
}


=head2 init_prompt

(Re-)initialize the date/time-related package variables

=cut

sub init_prompt {
    #print "Entering " . __PACKAGE__ . "::init_prompt\n";
    init_timepiece();
    $prompt_date = $today unless $prompt_date;
    ( $prompt_year, $prompt_month, $prompt_day ) = 
        $prompt_date =~ m/^(\d{4,4})-(\d{1,2})-(\d{1,2})/;
    ( $prompt_century ) = $prompt_year =~ m/^(\d{2,2})/;
}


=head2 month_alpha_to_numeric

Given a month written in English (e.g. "January"), return the ordinal
number of that month (i.e. 1 for January) or undef if it cannot be
determined.

=cut

sub month_alpha_to_numeric {
    my $alpha = shift;

lib/App/Dochazka/CLI/Util.pm  view on Meta::CPAN

    HH:MM:SS
    HH:MM

and any of the two-digit forms can be fulfilled by a single digit,
for example 6:4:9 is 6:04 a.m. and nine seconds

=over

=item * single-digit forms

If a single-digit form is given, a leading zero is appended.

=item * seconds

If seconds are given, they are ignored.

=item * no validation

No attempt is made to validate the time -- this is done later, by
PostgreSQL.

=back

=cut

sub normalize_time {
    my $rt = shift;  # rt == raw time

    return '00:00' unless $rt;

    # normalize time part
    $rt =~ m/\A(?<hh>\d{1,2}):(?<mm>\d{1,2})(:\d{1,2})?\z/;
    my ( $hours, $minutes ) = ( $+{hh}, $+{mm} );
    return undef unless defined( $hours ) and defined( $minutes );
    # handle single zeroes
    $hours = '00' if $hours eq '0';
    $minutes = '00' if $minutes eq '0';
    return undef unless $hours and $minutes;
    my $nt = sprintf( "%02d:%02d", $+{hh}, $+{mm} );
    
    return "$nt";
}


=head2 parse_test

Given a reference to the PARAMHASH a command handler was called with, check
if there is a PARSE_TEST property there, and if it is true return the
full subroutine name of the caller. 

=cut

sub parse_test {
    #print ( 'parse_test arg list: ' . join( ' ', @_ ) . "\n" );
    my ( %PARAMHASH ) = @_;
    if ( $PARAMHASH{'PARSE_TEST'} ) {
        return $CELL->status_ok( 'DOCHAZKA_CLI_PARSE_TEST', 
            payload => (caller(1))[3] );
    } 
    return $CELL->status_not_ok( 'DOCHAZKA_CLI_PARSE_TEST' );
}


=head2 refresh_current_emp

REST calls are cheap, so look up C<< $current_emp >> again just to make sure.

=cut

sub refresh_current_emp {
    my $status = send_req( 'GET', 'employee/eid/' . $current_emp->eid );
    if ( $status->not_ok ) {
        $log->crit( "Problem with data integrity (current employee)" );
        return $status;
    }
    $current_emp = App::Dochazka::Common::Model::Employee->spawn( %{ $status->payload } );
    return $status;
}


=head2 rest_error

Given a non-OK status object and a string briefly identifying (for the user)
the operation during which the error occurred, construct and return a new
L<App::CELL::Status> object bearing (in the payload) a string containing the
"error report" - perhaps suitable for displaying to the user.  The code of that
object is C<REST_ERROR> and its level is taken from the passed-in status
object. The other attributes of the original (passed-in) status object are
preserved in the returned status object as follows:

    payload -> rest_payload
    uri_path -> uri_path 
    http_status -> http_status

=cut

sub rest_error {
    my ( $status, $oper_desc ) = @_;
    my $rv = "\n";
    $rv .= "Entering " . __PACKAGE__ . "::rest_error ($oper_desc)"
        if $debug_mode;

    $rv .= "Error encountered on attempted operation \"$oper_desc\"\n";

    # special handling if payload is a string
    if ( ref( $status->payload ) eq '' ) {

        $rv .= $status->payload;
        $rv .= "\n";

    } elsif ( ref( $status->payload ) eq 'HASH' ) {

        my $http_status = $status->{'http_status'} || 
                          $status->payload->{'http_code'} || 
                          "Cannot be determined";
        my $method      = $status->payload->{'http_method'} || 
                          "Cannot be determined";
        my $uri_path    = $status->payload->{'uri_path'} || 
                          '';
        $rv .= "REST operation: $method $uri_path\n";
        $rv .= "HTTP status: $http_status\n";
        $rv .= "Explanation: ";
        $rv .= $status->code;
        $rv .= ( $status->code eq $status->text ) 
            ? "\n"
            : ': ' . $status->text . "\n";
        $rv .= "Permanent? ";
        $rv .= ( $status->payload->{'permanent'} )
            ? "YES\n"
            : "NO\n";

    } else {