App-Dochazka-REST
view release on metacpan or search on metacpan
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
sub _replace_payload_array_with_string {
my $status = shift;
$status->payload( $status->payload->[0] );
return $status;
}
=head2 canonicalize_tsrange
Given a string that might be a tsrange, "canonicalize" it by running it
through the database in the SQL statement:
SELECT CAST( ? AS tstzrange )
Returns an L<App::CELL::Status> object. If the status code is OK, then the
tsrange is OK and its canonicalized form is in the payload. Otherwise, some
kind of error occurred, as described in the status object.
=cut
sub canonicalize_tsrange {
my ( $conn, $tsr ) = @_;
my $status = select_single(
conn => $conn,
sql => 'SELECT CAST( ? AS tstzrange)',
keys => [ $tsr ],
);
_replace_payload_array_with_string( $status ) if $status->ok;
return $CELL->status_err( 'DOCHAZKA_TSRANGE_EMPTY' ) if $status->ok and $status->payload eq "empty";
return $status;
}
=head2 cud
Attempts to Create, Update, or Delete a single database record. Takes the
following PARAMHASH:
=over
=item * conn
The L<DBIx::Connector> object with which to gain access to the database.
=item * eid
The EID of the employee originating the request (needed for the audit triggers).
=item * object
The Dochazka datamodel object to be worked on.
=item * sql
The SQL statement to execute (should be INSERT, UPDATE, or DELETE).
=item * attrs
An array reference containing the bind values to be plugged into the SQL
statement.
=back
Returns a status object.
Important note: it is up to the programmer to not pass any SQL statement that
might affect more than one record.
=cut
sub cud {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
eid => { type => SCALAR },
object => { can => [ qw( insert delete ) ] },
sql => { type => SCALAR },
attrs => { type => ARRAYREF }, # order of attrs must match SQL statement
} );
my ( $status, $rv, $count );
try {
local $SIG{__WARN__} = sub {
die @_;
};
# start transaction
$ARGS{'conn'}->txn( fixup => sub {
# get DBI db handle
my $dbh = shift;
# set the dochazka.eid GUC session parameter
$dbh->do( $site->SQL_SET_DOCHAZKA_EID_GUC, undef, ( $ARGS{'eid'}+0 ) );
# prepare the SQL statement and bind parameters
my $sth = $dbh->prepare( $ARGS{'sql'} );
my $counter = 0;
map {
$counter += 1;
$sth->bind_param( $counter, $ARGS{'object'}->{$_} );
} @{ $ARGS{'attrs'} };
# execute the SQL statement
$rv = $sth->execute;
$log->debug( "cud: DBI execute returned " . Dumper( $rv ) );
if ( $rv == 1 ) {
# a record was returned; get the values
my $rh = $sth->fetchrow_hashref;
$log->info( "Statement " . $sth->{'Statement'} . " RETURNING values: " . Dumper( $rh ) );
# populate object with all RETURNING fields
map { $ARGS{'object'}->{$_} = $rh->{$_}; } ( keys %$rh );
# count number of rows affected
$count = $sth->rows;
} elsif ( $rv eq '0E0' ) {
# no error, but no record returned either
$count = $sth->rows;
} elsif ( $rv > 1 ) {
$status = $CELL->status_crit(
'DOCHAZKA_CUD_MORE_THAN_ONE_RECORD_AFFECTED',
args => [ $sth->{'Statement'} ]
);
} elsif ( $rv == -1 ) {
$status = $CELL->status_err(
'DOCHAZKA_CUD_UNKNOWN_NUMBER_OF_RECORDS_AFFECTED',
args => [ $sth->{'Statement'} ]
);
} else {
$status = $CELL->status_crit( 'DOCHAZKA_DBI_EXECUTE_WEIRDNESS' );
}
} );
} catch {
my $errmsg = $_;
if ( not defined( $errmsg ) ) {
$log->err( '$_ undefined in catch' );
$errmsg = '<NONE>';
}
if ( ! $site->DOCHAZKA_SQL_TRACE ) {
$errmsg =~ s/^DBD::Pg::st execute failed: //;
$errmsg =~ s#at /usr/lib/perl5/.* line .*\.$##;
}
if ( ! defined( $status ) ) {
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR',
args => [ $errmsg ],
DBI_return_value => $rv,
);
}
};
if ( not defined( $status ) ) {
$status = $CELL->status_ok( 'DOCHAZKA_CUD_OK',
DBI_return_value => $rv,
payload => $ARGS{'object'},
count => $count,
);
}
return $status;
}
=head2 cud_generic
Attempts to execute a generic Create, Update, or Delete database operation.
Takes the following PARAMHASH:
=over
=item * conn
The L<DBIx::Connector> object with which to gain access to the database.
=item * eid
The EID of the employee originating the request (needed for the audit triggers).
=item * sql
The SQL statement to execute (should be INSERT, UPDATE, or DELETE).
=item * bind_params
An array reference containing the bind values to be plugged into the SQL
statement.
=back
Returns a status object.
Important note: it is up to the programmer to not pass any SQL statement that
might affect more than one record.
=cut
sub cud_generic {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
eid => { type => SCALAR },
sql => { type => SCALAR },
bind_params => { type => ARRAYREF, optional => 1 }, # order must match SQL statement
} );
$log->info( "Entering " . __PACKAGE__ . "::cud_generic with" );
$log->info( "sql: $ARGS{sql}" );
$log->info( "bind_param: " . Dumper( $ARGS{bind_params} ) );
my ( $status, $rv, $count );
try {
local $SIG{__WARN__} = sub {
die @_;
};
# start transaction
$ARGS{'conn'}->txn( fixup => sub {
# get DBI db handle
my $dbh = shift;
# set the dochazka.eid GUC session parameter
$dbh->do( $site->SQL_SET_DOCHAZKA_EID_GUC, undef, ( $ARGS{'eid'}+0 ) );
# prepare the SQL statement and bind parameters
my $sth = $dbh->prepare( $ARGS{'sql'} );
my $counter = 0;
map {
$counter += 1;
$sth->bind_param( $counter, $_ || undef );
} @{ $ARGS{'bind_params'} };
# execute the SQL statement
$rv = $sth->execute;
$log->debug( "cud_generic: DBI execute returned " . Dumper( $rv ) );
if ( $rv >= 1 ) {
# count number of rows affected
$count = $sth->rows;
} elsif ( $rv eq '0E0' ) {
# no error, but no record returned either
$count = $sth->rows;
} elsif ( $rv == -1 ) {
$status = $CELL->status_err(
'DOCHAZKA_CUD_UNKNOWN_NUMBER_OF_RECORDS_AFFECTED',
args => [ $sth->{'Statement'} ]
);
} else {
$status = $CELL->status_crit( 'DOCHAZKA_DBI_EXECUTE_WEIRDNESS' );
}
} );
} catch {
my $errmsg = $_;
if ( not defined( $errmsg ) ) {
$log->err( '$_ undefined in catch' );
$errmsg = '<NONE>';
}
if ( not defined( $status ) ) {
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR',
args => [ $errmsg ],
DBI_return_value => $rv,
);
}
};
if ( not defined( $status ) ) {
$status = $CELL->status_ok( 'DOCHAZKA_CUD_OK',
DBI_return_value => $rv,
count => $count,
);
}
return $status;
}
=head2 decode_schedule_json
Given JSON string representation of the schedule, return corresponding HASHREF.
=cut
sub decode_schedule_json {
my ( $json_str ) = @_;
return unless $json_str;
return JSON->new->utf8->canonical(1)->decode( $json_str );
}
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
# consult the database; N.B. - select may only return a single record
my ( $hr, $status );
try {
$ARGS{'conn'}->run( fixup => sub {
$hr = $_->selectrow_hashref( $ARGS{'sql'}, undef, @{ $ARGS{'keys'} } );
} );
} catch {
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
};
# report the result
return $status if $status;
return $CELL->status_ok( 'DISPATCH_RECORDS_FOUND', args => [ '1' ],
payload => $ARGS{'class'}->spawn( %$hr ), count => 1 ) if defined $hr;
return $CELL->status_notice( 'DISPATCH_NO_RECORDS_FOUND', count => 0 );
}
=head2 load_multiple
Load multiple database records based on an SQL statement and a set of search
keys. Example:
my $status = load_multiple(
conn => $conn,
class => __PACKAGE__,
sql => $site->DOCHAZKA_SQL_SOME_STATEMENT,
keys => [ 'rom%' ]
);
The return value will be a status object, the payload of which will be an
arrayref containing a set of objects. The objects are constructed by calling
$ARGS{'class'}->spawn
For convenience, a 'count' property will be included in the status object.
=cut
sub load_multiple {
# get and verify arguments
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
class => { type => SCALAR },
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
$log->debug( "Entering " . __PACKAGE__ . "::load_multiple" );
my $status;
my $results = [];
try {
$ARGS{'conn'}->run( fixup => sub {
my $sth = $_->prepare( $ARGS{'sql'} );
my $bc = 0;
map {
$bc += 1;
$sth->bind_param( $bc, $_ || undef );
} @{ $ARGS{'keys'} };
$sth->execute();
# assuming they are objects, spawn them and push them onto @results
while( defined( my $tmpres = $sth->fetchrow_hashref() ) ) {
push @$results, $ARGS{'class'}->spawn( %$tmpres );
}
} );
} catch {
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
};
return $status if defined $status;
my $counter = scalar @$results;
$status = ( $counter )
? $CELL->status_ok( 'DISPATCH_RECORDS_FOUND',
args => [ $counter ], payload => $results, count => $counter, keys => $ARGS{'keys'} )
: $CELL->status_notice( 'DISPATCH_NO_RECORDS_FOUND',
payload => $results, count => $counter );
#$log->debug( Dumper $status );
return $status;
}
=head2 make_test_exists
Returns coderef for a function, 'test_exists', that performs a simple
true/false check for existence of a record matching a scalar search key. The
record must be an exact match (no wildcards).
Takes one argument: a type string C<$t> which is concatenated with the string
'load_by_' to arrive at the name of the function to be called to execute the
search.
The returned function takes a single argument: the search key (a scalar value).
If a record matching the search key is found, the corresponding object
(i.e. a true value) is returned. If such a record does not exist, 'undef' (a
false value) is returned. If there is a DBI error, the error text is logged
and undef is returned.
=cut
sub make_test_exists {
my ( $t ) = validate_pos( @_, { type => SCALAR } );
my $pkg = (caller)[0];
return sub {
my ( $conn, $s_key ) = @_;
require Try::Tiny;
my $routine = "load_by_$t";
my ( $status, $txt );
$log->debug( "Entered $t" . "_exists with search key $s_key" );
try {
no strict 'refs';
$status = $pkg->$routine( $conn, $s_key );
} catch {
$txt = "Function " . $pkg . "::test_exists was generated with argument $t, " .
"so it tried to call $routine, resulting in exception $_";
$status = $CELL->status_crit( $txt );
};
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
}
$log->debug("About to run SQL statement $sql with parameter $eid - " .
" called from " . (caller)[1] . " line " . (caller)[2] );
my $status;
try {
$conn->run( fixup => sub {
( $row ) = $_->selectrow_array( @args );
} );
} catch {
$log->debug( 'Encountered DBI error' );
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
};
return $status if $status;
$log->debug( "_st_by_eid success; returning payload " . Dumper( $row ) );
return $row;
}
=head2 select_single
Given a L<DBIx::Connector> object in the 'conn' property, a SELECT statement in
the 'sql' property and, in the 'keys' property, an arrayref containing a list
of scalar values to plug into the SELECT statement, run a C<selectrow_array>
and return the resulting list.
Returns a standard status object (see C<load> routine, above, for description).
=cut
sub select_single {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
my ( $status, @results );
$log->info( "select_single keys: " . Dumper( $ARGS{keys} ) );
try {
$ARGS{'conn'}->run( fixup => sub {
@results = $_->selectrow_array( $ARGS{'sql'}, undef, @{ $ARGS{'keys'} } );
} );
my $count = scalar( @results ) ? 1 : 0;
$log->info( "count: $count" );
$status = ( $count )
? $CELL->status_ok( 'DISPATCH_RECORDS_FOUND',
args => [ $count ], count => $count, payload => \@results )
: $CELL->status_notice( 'DISPATCH_NO_RECORDS_FOUND' );
} catch {
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
};
die "AAAAHAHAAHAAAAAAGGGH! " . __PACKAGE__ . "::select_single" unless $status;
return $status;
}
=head2 select_set_of_single_scalar_rows
Given DBIx::Connector object, an SQL statement, and a set of keys to bind
into the SQL statement, assume that the statement can return 0-n records
and that each record consists of a single field that must fit into a single
scalar value.
=cut
sub select_set_of_single_scalar_rows {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
$log->debug( "Entering " . __PACKAGE__ . "::select_set_of_single_scalar_rows with
paramhash " . Dumper( \%ARGS ) );
my ( $status, $result_set );
try {
$ARGS{'conn'}->run( fixup => sub {
my $sth = $_->prepare( $ARGS{'sql'} );
my $bc = 0;
map {
$bc += 1;
$sth->bind_param( $bc, $_ || undef );
} @{ $ARGS{'keys'} };
$sth->execute();
# push results onto $nicks
while( defined( my $tmpres = $sth->fetchrow_arrayref() ) ) {
push @$result_set, @$tmpres;
}
} );
} catch {
$log->debug( 'Encountered DBI error' );
$status = $CELL->status_err( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
};
return $status if $status;
return $CELL->status_ok( 'RESULT_SET', payload => $result_set );
}
=head2 split_tsrange
Given a string that might be a tsrange, run it through the database
using the SQL statement:
SELECT lower(CAST( ? AS tstzrange )), upper(CAST( ? AS tstzrange ))
If all goes well, the result will be an array ( from, to ) of two
timestamps.
Returns a status object.
=cut
sub split_tsrange {
my ( $conn, $tsr ) = @_;
my $status = select_single(
conn => $conn,
sql => 'SELECT lower(CAST( ? AS tstzrange )), upper(CAST( ? AS tstzrange ))',
keys => [ $tsr, $tsr ],
);
return $status unless $status->ok;
my ( $lower, $upper ) = @{ $status->payload };
return $CELL->status_err( 'DOCHAZKA_UNBOUNDED_TSRANGE' ) unless defined( $lower ) and
defined( $upper ) and $lower ne 'infinity' and $upper ne 'infinity';
return $status;
}
=head2 timestamp_delta_minus
Given a timestamp string and an interval string (e.g. "1 week 3 days" ),
subtract the interval from the timestamp.
Returns a status object. If the database operation is successful, the payload
will contain the resulting timestamp.
=cut
sub timestamp_delta_minus {
my ( $conn, $ts, $delta ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
( run in 0.935 second using v1.01-cache-2.11-cpan-2398b32b56e )