App-Dochazka-CLI
view release on metacpan or search on metacpan
lib/App/Dochazka/CLI/Util.pm view on Meta::CPAN
}
#
# 2. if it's a range, convert it into a list of individual dates
if ( my ( $begin, $end ) = $subtoken =~ m/^(\d{1,2})-(\d{1,2})$/ ) {
if ( $begin >= $end ) {
die "AGHGGHSKSKDQ!!!!! Begin date must be less than end";
}
foreach my $n ( $begin..$end ) {
my $canonical_date = sprintf( "%04d-%02d-%02d", $prompt_year, $prompt_month, $n );
push @datelist, $canonical_date;
}
#
# 3. if not, convert it into a date
} else { # is a single date
my $canonical_date = sprintf( "%04d-%02d-%02d", $prompt_year, $prompt_month, $subtoken );
push @datelist, $canonical_date;
}
}
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
lib/App/Dochazka/CLI/Util.pm view on Meta::CPAN
$nd = $prompt_year . '-' . $rd;
} elsif ( $rd =~ m/\Atod/i ) {
$nd = $today;
} elsif ( $rd =~ m/\Atom/i ) {
$nd = $tomorrow;
} elsif ( $rd =~ m/\Ayes/i ) {
$nd = $yesterday;
} elsif ( $rd =~ m/\A[\+\-]\d{1,3}\z/ ) {
# offset from prompt date
$prompt_date =~ m/\A(?<yyyy>\d{4,4})-(?<mm>\d{1,2})-(?<dd>\d{1,2})\z/;
if ( check_date( $+{'yyyy'}, $+{'mm'}, $+{'dd'} ) ) {
# prompt date is OK, apply delta
my ( $year, $month, $day ) = Add_Delta_Days(
$+{'yyyy'}, $+{'mm'}, $+{'dd'},
$rd,
);
$nd = "$year-$month-$day";
} else {
die "AAAAAAJAJAJAJADDEEEEE!!! Invalid prompt date $prompt_date";
}
} else {
# anything else - invalid timestamp
return undef;
}
# add leading zeroes to month and day, if necessary
$nd =~ m/\A(?<yyyy>\d{4,4})-(?<mm>\d{1,2})-(?<dd>\d{1,2})\z/;
return undef unless $+{yyyy} and $+{mm} and $+{dd};
$nd = sprintf( "%d-%02d-%02d", $+{yyyy}, $+{mm}, $+{dd} );
# sanity check to ensure no weird dates slip by
my ( $year, $month, $day ) = $nd =~ m/\A(\d{4,4})-(\d{2,2})-(\d{2,2})\z/;
return undef unless check_date( $year, $month, $day );
return "$nd";
}
=head2 normalize_time
Normalize a time entered by the user. A time can take the following forms
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;
}
lib/App/Dochazka/CLI/Util.pm view on Meta::CPAN
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 {
die "AH! in rest_error, payload is neither a hashref nor an ordinary scalar";
}
my $status_clone = App::CELL::Status->new(
level => $status->level,
code => 'REST_ERROR',
payload => $rv,
rest_payload => $status->payload,
uri_path => $status->{'uri_path'},
http_status => $status->{'http_status'},
);
return $status_clone;
}
=head2 truncate_to
Given a string and a maximum length (defaults to 32), truncates to that length.
Returns a copy of the string. If any characters were actually removed in the
truncate operation, '...' is appended -- unless the maximum length is zero, in
which case the empty string is returned.
=cut
sub truncate_to {
my ( $str, $mlen ) = validate_pos( @_,
{ type => SCALAR|UNDEF },
{
callbacks => {
'greater than or equal to zero' => sub { shift() >= 0 },
},
optional => 1,
type => SCALAR,
},
);
$mlen = 32 unless defined( $mlen );
my $len = length $str || 0; # $str might be undef
return $str unless $len > $mlen;
my $str_copy = substr( $str, 0, $mlen );
$str_copy .= '...' if $len > $mlen;
$str_copy = '' if $mlen == 0;
return $str_copy; # might be undef
}
1;
( run in 0.712 second using v1.01-cache-2.11-cpan-5b529ec07f3 )