view release on metacpan or  search on metacpan

lib/App/Dochazka/REST/Model/Shared.pm  view on Meta::CPAN

        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 );
        };
        if ( ! defined( $status ) or $status->level eq 'CRIT' ) {
            die $txt;
        }
        #$log->debug( "Status is " . Dumper( $status ) );
        return $status->payload if $status->ok;
        return;
    }
}


=head2 noof

Given a L<DBIx::Connector> object and the name of a data model table, returns
the total number of records in the table.

    activities employees intervals locks privhistory schedhistory
    schedintvls schedules tempintvls

On failure, returns undef.

=cut

sub noof {
    my ( $conn, $table ) = validate_pos( @_, 
        { isa => 'DBIx::Connector' },
        { type => SCALAR } 
    );

    return unless grep { $table eq $_; } qw( activities employees intervals locks
            privhistory schedhistory schedintvls schedules tempintvls );

    my $count;
    try {
        $conn->run( fixup => sub {
            ( $count ) = $_->selectrow_array( "SELECT count(*) FROM $table" );
        } );
    } catch {
        $CELL->status_crit( 'DOCHAZKA_DBI_ERR', args => [ $_ ] );
    };
    return $count;
}


=head2 priv_by_eid

Given an EID, and, optionally, a timestamp, returns the employee's priv
level as of that timestamp, or as of "now" if no timestamp was given. The
priv level will default to 'passerby' if it can't be determined from the
database.

=cut

sub priv_by_eid {
    my ( $conn, $eid, $ts ) = validate_pos( @_, 
        { isa => 'DBIx::Connector' },
        { type => SCALAR },
        { type => SCALAR|UNDEF, optional => 1 } 
    );
    #$log->debug( "priv_by_eid: EID is " . (defined( $eid ) ? $eid : 'undef') . " - called from " . (caller)[1] . " line " . (caller)[2] );
    return _st_by_eid( $conn, 'priv', $eid, $ts );
}


=head2 schedule_by_eid

Given an EID, and, optionally, a timestamp, returns the SID of the employee's
schedule as of that timestamp, or as of "now" if no timestamp was given.

=cut

sub schedule_by_eid {
    my ( $conn, $eid, $ts ) = validate_pos( @_, 
        { isa => 'DBIx::Connector' },
        { type => SCALAR },
        { type => SCALAR|UNDEF, optional => 1 },
    );
    return _st_by_eid( $conn, 'schedule', $eid, $ts );
}


=head3 _st_by_eid 

Function that 'priv_by_eid' and 'schedule_by_eid' are wrappers of.

=cut

sub _st_by_eid {
    my ( $conn, $st, $eid, $ts ) = @_;
    my ( @args, $sql, $row );
    $log->debug( "Entering _st_by_eid with \$st == $st, \$eid == $eid, \$ts == " . ( $ts || '<NONE>' ) );
    if ( $ts ) {
        # timestamp given
        if ( $st eq 'priv' ) {
            $sql = $site->SQL_EMPLOYEE_PRIV_AT_TIMESTAMP;
        } elsif ( $st eq 'schedule' ) {
            $sql = $site->SQL_EMPLOYEE_SCHEDULE_AT_TIMESTAMP;
        } 
        @args = ( $sql, undef, $eid, $ts );
    } else {
        # no timestamp given
        if ( $st eq 'priv' ) {
            $sql = $site->SQL_EMPLOYEE_CURRENT_PRIV;
        } elsif ( $st eq 'schedule' ) {
            $sql = $site->SQL_EMPLOYEE_CURRENT_SCHEDULE;
        } 
        @args = ( $sql, undef, $eid );
    }

    $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.