view release on metacpan or  search on metacpan

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

=item * L<reset> (recycles an existing object by setting it to desired state)

=item * L<TO_JSON> (returns 'unblessed' version of an Activity object)

=item * L<compare> (compare two objects)

=item * L<clone> (clone an object)

=item * L<insert> (inserts object into database)

=item * L<update> (updates database to match the object)

=item * L<delete> (deletes record from database if nothing references it)

=item * L<load_by_cid> (loads a single activity into an object)

=item * L<load_by_path> (loads a single activity into an object)

=back

L<App::Dochazka::REST::Model::Component> also exports some convenience
functions:

=over

=item * L<cid_exists> (boolean function)

=item * L<path_exists> (boolean function)

=item * L<cid_by_path> (given a path, returns CID)

=item * L<get_all_components> (self-explanatory)

=back

For basic C<component> object workflow, see the unit tests in
C<t/model/component.t>.

=cut

use Exporter qw( import );
our @EXPORT_OK = qw( cid_exists path_exists cid_by_path get_all_components );




=head1 METHODS


=head2 insert

Instance method. Takes the object, as it is, and attempts to insert it into
the database. On success, overwrites object attributes with field values
actually inserted. Returns a status object.

=cut

sub insert {
    my $self = shift;
    my ( $context ) = validate_pos( @_, { type => HASHREF } );

    return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless
        ( 
          $self->{'path'} and $self->{'source'} and $self->{'acl'} and
          scalar( 
              grep { $self->{'acl'} eq $_ } ( 'admin', 'active', 'inactive', 'passerby' ) 
          ) 
        );

    my $status = cud(
        conn => $context->{'dbix_conn'},
        eid => $context->{'current'}->{'eid'},
        object => $self,
        sql => $site->SQL_COMPONENT_INSERT,
        attrs => [ 'path', 'source', 'acl', 'validations' ],
    );

    $self->create_file if $status->ok;

    return $status;
}


=head2 update

Instance method. Assuming that the object has been prepared, i.e. the CID
corresponds to the component to be updated and the attributes have been
changed as desired, this function runs the actual UPDATE, hopefully
bringing the database into line with the object. Overwrites all the
object's attributes with the values actually written to the database.
Returns status object.

=cut

sub update {
    my $self = shift;
    my ( $context ) = validate_pos( @_, { type => HASHREF } );

    return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless
        ( 
          $self->{'cid'} and 
          ( 
              $self->{'path'} or $self->{'source'} or $self->{'acl'}
          )
        );

    return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) if
        (
          $self->{'acl'} and not scalar( 
              grep { $self->{'acl'} eq $_ } ( 'admin', 'active', 'inactive', 'passerby' ) 
          ) 
        );

    my $status = cud(
        conn => $context->{'dbix_conn'},
        eid => $context->{'current'}->{'eid'},
        object => $self,
        sql => $site->SQL_COMPONENT_UPDATE,
        attrs => [ 'path', 'source', 'acl', 'validations', 'cid' ],
    );

    $self->create_file if $status->ok;

    return $status;
}


=head2 delete

Instance method. Assuming the CID really corresponds to the component to be
deleted, this method will execute the DELETE statement in the database. No 
attempt is made to protect from possible deleterious consequences of
deleting components. Returns a status object.

=cut

sub delete {
    my $self = shift;
    my ( $context ) = validate_pos( @_, { type => HASHREF } );

    my $status = cud(
        conn => $context->{'dbix_conn'},
        eid => $context->{'current'}->{'eid'},
        object => $self,
        sql => $site->SQL_COMPONENT_DELETE,
        attrs => [ 'cid' ],
    );
    if ( $status->ok ) {
        $self->delete_file;
        $self->reset( cid => $self->{cid} );
    }

    return $status;
}


=head2 load_by_cid

Loads component from database, by the CID provided in the argument list,
into a newly-spawned object. The CID must be an exact match.  Returns a
status object: if the object is loaded, the status code will be
'DISPATCH_RECORDS_FOUND' and the object will be in the payload; if 
the CID is not found in the database, the status code will be
'DISPATCH_NO_RECORDS_FOUND'. A non-OK status indicates a DBI error.

=cut

sub load_by_cid {
    my $self = shift;
    my ( $conn, $cid ) = validate_pos( @_,
        { isa => 'DBIx::Connector' },
        { type => SCALAR },
    );

    return load( 
        conn => $conn,
        class => __PACKAGE__, 
        sql => $site->SQL_COMPONENT_SELECT_BY_CID,
        keys => [ $cid ],
    );
}


=head2 load_by_path

Analogous method to L<"load_by_cid">.

=cut

sub load_by_path {
    my $self = shift;
    my ( $conn, $path ) = validate_pos( @_,
        { isa => 'DBIx::Connector' },
        { type => SCALAR },
    );

    $path =~ s{^/}{};

    return load( 
        conn => $conn,
        class => __PACKAGE__, 
        sql => $site->SQL_COMPONENT_SELECT_BY_PATH,
        keys => [ $path ],
    );
}


=head2 create_file

Create Mason component file under $comp_root

=cut

sub create_file {
    my $self = shift;
    my ( undef, $dirspec, $filespec ) = File::Spec->splitpath( $self->path );
    my $full_path = File::Spec->catfile( $comp_root, $dirspec );
    mkpath( $full_path, 0, 0750 );
    $full_path = File::Spec->catfile( $full_path, $filespec );
    open(my $fh, '>', $full_path) or die "Could not open file '$full_path' $!";
    print $fh $self->source;
    close $fh;
    return;
}


=head2 delete_file

Delete Mason component file under $comp_root

=cut

sub delete_file {
    my $self = shift;
    my $full_path = File::Spec->catfile( $comp_root, $self->path );
    my $count = unlink $full_path;
    if ( $count == 1 ) {
        $log->info( "Component.pm->delete_file: deleted 1 file $full_path" );
    } else {
        $log->error( "Component.pm->delete_file: deleted $count files" );
    }
    return;
}


=head2 generate

Generate output

=cut

sub generate {
    my $self = shift;
    my %ARGS = @_;
    my $path = $self->path;

    # the path in the Component object may or may not start with a '/'
    # Mason requires that it start with an '/', even though it's relative
    $path = '/' . $path unless $path =~ m{^/};

    # the path should exist and be readable
    my $full_path = File::Spec->catfile( $comp_root, $self->path );
    return "$full_path does not exist" unless -e $full_path;
    return "$full_path is not readable" unless -r $full_path;

    # only top-level components can be used to produce output
    # top-level components must end in '.mc' or '.mp', but Mason 
    # expects the component name to be specified without the extension
    return $self->path . " is not a top-level component" unless $path =~ m/\.m[cp]$/;
    $path =~ s/\.m[cp]$//;

    return $interp->run($path, %ARGS)->output;
}


=head1 FUNCTIONS

The following functions are not object methods.


=head2 cid_exists

Boolean function


=head2 path_exists

Boolean function

=cut

BEGIN {
    no strict 'refs';
    *{'cid_exists'} = App::Dochazka::REST::Model::Shared::make_test_exists( 'cid' );
    *{'path_exists'} = App::Dochazka::REST::Model::Shared::make_test_exists( 'path' );
}


=head2 cid_by_path

Given a path, attempt to retrieve the corresponding CID.
Returns CID or undef on failure.

=cut

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

    my $status = __PACKAGE__->load_by_path( $conn, $path );
    return $status->payload->{'cid'} if $status->code eq 'DISPATCH_RECORDS_FOUND';
    return;
}



=head2 get_all_components

Returns a reference to a hash of hashes, where each hash is one component object.

=cut

sub get_all_components {
    my $conn = shift;
    
    my $sql = $site->SQL_COMPONENT_SELECT_ALL;

    return load_multiple(
        conn => $conn,
        class => __PACKAGE__,
        sql => $sql,
        keys => [],
    );
}




=head1 AUTHOR

Nathan Cutler, C<< <presnypreklad@gmail.com> >>

=cut 

1;