App-Dochazka-REST

 view release on metacpan or  search on metacpan

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

our $faux_context;



=head1 FUNCTIONS


=head2 run_sql

Takes a L<DBIx::Connector> object and an array of SQL statements. Runs them 
one by one until an exception is thrown or the last statement completes
successfully. Returns a status object which will be either OK or ERR.
If NOT_OK, the error text will be in C<< $status->text >>.

=cut

sub run_sql {
    my ( $conn, @stmts ) = @_;
    my $status;
    try {
        foreach my $stmt ( @stmts ) {

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

singleton.

=cut

sub conn_up {
    my $arg = shift;
    my $conn = $arg || $dbix_conn;
    my $bool = 0;
    return $bool unless ref( $conn ) eq 'DBIx::Connector';
    
    # the ping command can and will throw and exception if the database server
    # is unreachable
    try {
        $bool = $conn->dbh->ping;
    };

    return $bool;
}


=head2 conn_status 

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

        # Wipe out current TIID
        $self->DESTROY;

        # Set attributes to run-time values sent in argument list.
        # Attributes that are not in the argument list will get set to undef.
        map { $self->{$_} = $ARGS{$_}; } keys %attr;

        # run the populate function, if any
        $self->populate() if $self->can( 'populate' );

        # return an appropriate throw-away value
        return;
    };

    *{ 'TO_JSON' } = sub {
        my $self = shift;
        my $unblessed_copy;
        map { $unblessed_copy->{$_} = $self->{$_}; } keys %attr;
        return $unblessed_copy;
    };

t/dispatch/activity.t  view on Meta::CPAN

is( $status->payload->{'long_desc'}, 'wop wop ng', "POST $base 7" );

note( 'non-existent AID and also out of range' );
$activity_obj = '{ "aid" : 3434342342342, "long_desc" : 3434341, "remark" : 34334342 }';
dbi_err( $test, 500, 'root', 'POST', $base, $activity_obj, qr/out of range for type integer/ );

note( 'non-existent AID' );
$activity_obj = '{ "aid" : 342342342, "long_desc" : 3434341, "remark" : 34334342 }';
req( $test, 404, 'root', 'POST', $base, $activity_obj );

note( 'throw a couple curve balls' );
my $weirded_object = '{ "copious_turds" : 555, "long_desc" : "wang wang wazoo", "disabled" : "f" }';
req( $test, 400, 'root', 'POST', $base, $weirded_object );

my $no_closing_bracket = '{ "copious_turds" : 555, "long_desc" : "wang wang wazoo", "disabled" : "f"';
req( $test, 400, 'root', 'POST', $base, $no_closing_bracket );

$weirded_object = '{ "aid" : "!!!!!", "long_desc" : "down it goes" }';
dbi_err( $test, 500, 'root', 'POST', $base, $weirded_object, qr/invalid input syntax for type integer/ );

note( 'delete the testing activity' );

t/dispatch/activity.t  view on Meta::CPAN

note( "update: expected behavior" );
$activity_obj = '{ "code" : "FOOWANG", "remark" : "this is only a test" }';
req( $test, 403, 'demo', 'POST', $base, $activity_obj );
req( $test, 403, 'active', 'POST', $base, $activity_obj );
$status = req( $test, 200, 'root', 'POST', $base, $activity_obj );
is( $status->level, 'OK', "POST $base 4" );
is( $status->code, 'DOCHAZKA_CUD_OK', "POST $base 5" );
is( $status->payload->{'remark'}, 'this is only a test', "POST $base 6" );
is( $status->payload->{'long_desc'}, 'wang wang wazoo', "POST $base 7" );

note( "throw a couple curve balls" );
$weirded_object = '{ "copious_turds" : 555, "long_desc" : "wang wang wazoo", "disabled" : "f" }';
req( $test, 400, 'root', 'POST', $base, $weirded_object );

$no_closing_bracket = '{ "copious_turds" : 555, "long_desc" : "wang wang wazoo", "disabled" : "f"';
req( $test, 400, 'root', 'POST', $base, $no_closing_bracket );

$weirded_object = '{ "code" : "!!!!!", "long_desc" : "down it goes" }';
dbi_err( $test, 500, 'root', 'POST', $base, $weirded_object, qr/check constraint "kosher_code"/ );

note( "delete the testing activity" );

t/dispatch/component.t  view on Meta::CPAN

is( "wop wop ng", read_file( $full_path_of_foowop ) );

note( 'non-existent cid and also out of range' );
$component_obj = '{ "cid" : 3434342342342, "source" : 3434341, "acl" : "passerby" }';
dbi_err( $test, 500, 'root', 'POST', $base, $component_obj, qr/out of range for type integer/ );

note( 'non-existent cid' );
$component_obj = '{ "cid" : 342342342, "source" : 3434341, "acl" : "passerby" }';
req( $test, 404, 'root', 'POST', $base, $component_obj );

note( 'throw a couple curve balls' );
my $weirded_object = '{ "copious_turds" : 555, "source" : "wang wang wazoo", "acl" : "passerby" }';
req( $test, 400, 'root', 'POST', $base, $weirded_object );

my $no_closing_bracket = '{ "copious_turds" : 555, "source" : "wang wang wazoo", "acl" : "passerby"';
req( $test, 400, 'root', 'POST', $base, $no_closing_bracket );

$weirded_object = '{ "cid" : "!!!!!", "source" : "down it goes" }';
dbi_err( $test, 500, 'root', 'POST', $base, $weirded_object, qr/invalid input syntax for type integer/ );

my $illegal_acl = '{ "cid" : ' . $cid_of_foowop . ', "path" : "library/machinations.mc", "source" : "wang wang wazoo", "acl" : "puppy" }';

t/dispatch/component.t  view on Meta::CPAN

note( "update: expected behavior" );
$component_obj = '{ "path" : "library/foowang.mc", "source" : "this is only a test", "acl" : "inactive" }';
req( $test, 403, 'demo', 'POST', $base, $component_obj );
$status = req( $test, 200, 'root', 'POST', $base, $component_obj );
is( $status->level, 'OK', "POST $base 4" );
is( $status->code, 'DOCHAZKA_CUD_OK', "POST $base 5" );
is( $status->payload->{'source'}, 'this is only a test', "POST $base 6" );
is( $status->payload->{'acl'}, 'inactive', "POST $base 7" );
is( "this is only a test", read_file( $full_path_of_foowang ) );

note( "throw a couple curve balls" );
$weirded_object = '{ "copious_turds" : 555, "source" : "wang wang wazoo", "acl" : "admin" }';
req( $test, 400, 'root', 'POST', $base, $weirded_object );

$no_closing_bracket = '{ "path" : "library/machinations.mc", "source" : "wang wang wazoo", "acl" : "admin"';
req( $test, 400, 'root', 'POST', $base, $no_closing_bracket );

$weirded_object = '{ "path" : "!!!!!", "source" : "down it goes", "acl" : "inactive" }';
#$status = req( $test, 400, 'root', 'POST', $base, $weirded_object );
#like( $status->text, qr/check constraint "kosher_path"/ );
dbi_err( $test, 500, 'root', 'POST', $base, $weirded_object, qr/check constraint "kosher_path"/ );

t/dispatch/interval_lock.t  view on Meta::CPAN

{ "$idmap{$il}" : 3434342342342, "remark" : 34334342 }
EOH
    dbi_err( $test, 500, 'root', 'POST', $base, $int_obj, qr/out of range for type integer/ );
    
    note( 'non-existent ID' );
    $int_obj = <<"EOH";
{ "$idmap{$il}" : 342342342, "remark" : 34334342 }
EOH
    req( $test, 404, 'root', 'POST', $base, $int_obj );
    
    note( 'throw a couple curve balls: weirded object' );
    my $weirded_object = '{ "copious_turds" : 555, "long_desc" : "wang wang wazoo", "disabled" : "f" }';
    req( $test, 400, 'root', 'POST', $base, $weirded_object );
    
    note( 'throw a couple curve balls: no closing bracket' );
    my $no_closing_bracket = '{ "copious_turds" : 555, "long_desc" : "wang wang wazoo", "disabled" : "f"';
    req( $test, 400, 'root', 'POST', $base, $no_closing_bracket );
    
    note( 'throw a couple curve balls: weirded object 2' );
    $weirded_object = "{ \"$idmap{$il}\" : \"!!!!!\", \"remark\" : \"down it goes\" }";
    dbi_err( $test, 500, 'root', 'POST', $base, $weirded_object, qr/invalid input syntax for type integer/ );
    
    note( 'can a different active employee edit active\'s interval?' );
    note( 'let bubba try it' );
    req( $test, 403, 'bubba', 'POST', "$il/$idmap{$il}", <<"EOH" );
{ "$idmap{$il}" : $test_id, "remark" : "mine" }
EOH

    note( 'can a different active employee edit active\'s interval?' );

t/fillup.t  view on Meta::CPAN

        emp_obj => App::Dochazka::REST::Model::Employee->spawn,
        intervals => [],
        long_desc => '',
        remark => '',
        tiid => '',
        tsrange => {},
        tsranges => [],
    );
    map 
    {
        my $throwaway = $attr_test{ $_ };
        $fo->$_( $throwaway );
        is( $fo->$_, $throwaway );
    } keys %attr_test;
}

note( $note = 'further test inherited accessors pathological' );
$log->info( "=== $note" );
{
    my %attr_test = (
        act_obj => '',
        constructor_status => '',
        context => [],

t/fillup.t  view on Meta::CPAN

        emp_obj => '',
        intervals => {},
        long_desc => {},
        remark => {},
        tiid => {},
        tsrange => '',
        tsranges => '',
    );
    map 
    {
        my $throwaway = $attr_test{ $_ };
        like(
            exception { $fo->$_( $throwaway ) },
            qr/which is not one of the allowed types:/
        );
    } keys %attr_test;
}

note( $note = 'further test selected accessors non-pathological' );
$log->info( "=== $note" );

my $context = { 'heaven' => 'angel' };
$fo->context( $context  );