File Coverage

blib/lib/CatalystX/Imports/Vars.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package CatalystX::Imports::Vars;

=head1 NAME

CatalystX::Imports::Vars - Import application variables

=cut

use warnings;
use strict;

=head1 BASE CLASSES

L<CatalystX::Imports>

=cut

use base 'CatalystX::Imports';

use Carp::Clan  qw{ ^CatalystX::Imports(?:::|$) };
use Data::Alias qw( alias deref );

=head1 SYNOPSIS

  package MyApp::Controller::Users;
  use base 'Catalyst::Controller';

  # use Vars => 1; for just $self, $ctx and @args
  use CatalystX::Imports
      Vars => { Stash   => [qw( $user $user_rs $template )],
                Session => [qw( $user_id )] };

  sub list: Local {
      $template = 'list.tt';
      $user_rs  = $ctx->model('User')->search;
  }

  sub view: Local {
      $template = 'view.tt';
      $user     = $ctx->model('User')->find($args[0]);
  }

  sub me: Local {
      $ctx->forward('view', [$user_id]);
  }

  1;

=head1 DESCRIPTION

This module allows you to bind various package vars in your controller
to specific places in the framework. By default, the variables C<$self>,
C<$ctx> and C<@args> are exported. They have the same value as if set
via

  my ($self, $ctx, @args) = @_;

in your action.

You can use a hash reference to specify what variables you want to bind
to their respective fields in the session or stash, as demonstrated in
the L</SYNOPSIS>.

=cut

=head1 METHODS

=head2 export_into

Exports requested variables and intalls a wrapper to fill them with their
respective values if needed.

=cut

sub export_into {
    my ($class, $target, $args) = @_;

    # a simple '1' means only $self, $ctx and $args are requested
    if ($args and $args == 1) {
        $args = {};
    }

    # by now it should be a hash reference, or we got something wrong
    croak 'Either a 1 or a hash reference expected as argument for Vars'
        unless $args and ref $args eq 'HASH';

    # fetch session and
    my @session = @{ $args->{Session} || [] };
    my @stash   = @{ $args->{Stash}   || [] };

    # build map of symbol hash refs, containing method, type and
    # sym (name)
    my @sym =
        map { {method => $_->[0], type => $_->[2], sym => $_->[3]} }
        map { [@$_, $class->_destruct_var_name($_->[1])] }
        map { my $x = $_; map { [$x->[0], $_] } @{ $x->[1] } }
            [session => \@session], [stash => \@stash];

    # export all symbols into the requesting namespace, include defaults
    $class->export_var_into($target, $class->_destruct_var_name($_))
        for @session, @stash, qw($self $ctx @args);

    # build and register our action wrapper
    $class->register_action_wrap_in($target, sub {
        my $code = shift;
        my @wrap = @{ shift(@_) };
        my ($self, $ctx, @args) = @_;

        # install default vars
        no strict 'refs';
        local *{ $target . '::self' } = \$self;
        local *{ $target . '::ctx'  } = \$ctx;
        local *{ $target . '::args' } = \@args;

        # localise symbols to this level
        local *{ "${target}::${_}" } for map { $_->{sym} } @sym;

        # scalar aliases
        alias ${ "${target}::" . $_->{sym} } =
            $ctx->can($_->{method})->($ctx)->{ $_->{sym} }
            for grep { $_->{type} eq 'scalar' } @sym;

        # hash aliases
        alias %{ "${target}::" . $_->{sym} } =
            %{ $ctx->can($_->{method})->($ctx)->{ $_->{sym} } ||= {} }
            for grep { $_->{type} eq 'hash' } @sym;

        # array aliases
        alias @{ "${target}::" . $_->{sym} } =
            @{ $ctx->can($_->{method})->($ctx)->{ $_->{sym} } ||= [] }
            for grep { $_->{type} eq 'array' } @sym;

        # there are other wrappers left
        if (my $w = shift @wrap) {
            return $w->($code, \@wrap, @_);
        }

        # we're the last wrapper
        else {
            return $code->(@_);
        }
    });

    return 1;
}

=head2 export_var_into

Installs a variable into a package.

=cut

sub export_var_into {
    my ($class, $target, $type, $name) = @_;
    my $target_name = "${target}::${name}";

    # initialise exported vars
    no strict 'refs';
    *$target_name =
        ( $type eq 'scalar' ? \$$target_name
        : $type eq 'array'  ? \@$target_name
        :                     \%$target_name );

    return 1;
}

=head2 _destruct_var_name

Takes a variable name and returns it's type (C<scalar>, C<array> or
C<hash>) and it's symbol parts.

=cut

sub _destruct_var_name {
    my ($class, $name) = @_;
    if ($name =~ /^([\@\%\$])(\S+)$/) {
        my ($sigil, $id) = ($1, $2);
        my %type = qw($ scalar % hash @ array);
        return ($type{ $sigil }, $id);
    }
    else {
        croak "Invalid identifier found: '$name'";
    }
}

=head1 DIAGNOSTICS

=head2 Invalid identifier found: 'foo'

You asked for the import of the var 'foo', but it is not a valid variable
identifier. E.g.: '@foo', '%foo' and '$foo' are valid, but '-foo', ':foo'
and 'foo' are not.

=head2 Either a 1 or a hash reference expected as argument for Vars

You can import just the default variables ($self, $ctx and @args) by
specifying a C<1> as a parameter ...

  use CatalystX::Imports Vars => 1;

... or you can give it a hash reference and tell it what you want
additionally ...

  use CatalystX::Imports Vars => { Stash => [qw($foo)] };

... but you specified something else as parameter.

=head1 SEE ALSO

L<Catalyst>,
L<CatalystX::Imports>,
L<CatalystX::Imports::Context>

=head1 AUTHOR AND COPYRIGHT

Robert 'phaylon' Sedlacek C<E<lt>[e-mail]<gt>>

=head1 LICENSE

This program is free software; you can redistribute it and/or modify
it under the same terms as perl itself.

=cut


1;