CatalystX::Controller::Sugar - Sugar for Catalyst controller

CatalystX-Controller-Sugar documentation Contained in the CatalystX-Controller-Sugar distribution.

Index

Code Index:

NAME

Top

CatalystX::Controller::Sugar - Sugar for Catalyst controller

VERSION

Top

0.0901

DESCRIPTION

Top

This module is written to simplify the way controllers are written. I personally think that shifting off $c and $self in every action is tidious. I also wanted a simpler API to created chained actions, since I rarely use any other actions - except of private.

SYNOPSIS

Top

  package MyApp::Controller::Root;
  use CatalystX::Controller::Sugar;

  __PACKAGE__->config->{'namespace'} = q();

  # Private action
  private authenticate => sub {
    c->user_exists and return 1;
  };

  # Chain /
  chain sub {
    report debug => 'Someone tries to access %s', c->action;
  };

  # Endpioint /*
  chain '' => sub {
    res->body('not found');
  };

  # Endpoint /login
  chain login => {
    get => sub {}, # show template
    post => sub {
      forward 'authenticate' and go '';
    },
  };

  # Chain /user/[id]/*
  chain user => ['id'], sub {
    stash user => c->model('DB::User')->find($_[0]);
  };

  # Endpoint /user/[id]/view/*
  chain 'user:1' => view => sub {
    res->body(
      sprintf 'Person is called: %s', stash->{'user'}->name
    );
  };

Same with standard Catalyst syntax

  package MyApp::Controller::Root;
  use Moose;
  BEGIN { extends 'Catalyst::Controller' }

  __PACKAGE__->config->{'namespace'} = q();

  # Private action
  sub authenticate :Private {
    my($self, $c) = @_;
    $c->user_exists and return 1;
  }

  # Chain /
  sub root :Chained("/") PathPart("") CaptureArgs(0) {
    my($self, $c) = @_;
    $c->log->debug(sprintf 'Someone tries to access %s', $c->action);
  }

  # Endpioint /*
  sub default :Chained("/root") PathPart("") Args {
    my($self, $c) = @_;
    $c->res->body('not found');
  }

  # Endpoint /login
  sub login :Chained("/root") PathPart Args {
    my($self, $c) = @_;

    if(lc $c->req->method eq 'get') {
      return; # show template
    }
    elsif(lc $c->req->method eq 'post') {
      $c->forward('authenticate') and go('');
    }
  }

  # Chain /user/[id]/*
  sub user :Chained("/root") PathPart CaptureArgs(1) {
    my($self, $c, $id) = @_;

    $c->stash->{'id'} = $id; # alternative to captured('id');
    $c->stash->{'user'} = $c->model('DB::User')->find($id);
  }

  # Endpoint /user/[id]/view/*
  sub user_view :Chained("/user") PathPart('view') Args {
    my($self, $c) = @_;
    $c->res->body(sprintf 'Person is called: %s', $c->stash->{'user'}->name);
  }

NOTE

$self and $c is not part of the argument list inside a chain() or private() action. $c is acquired by calling c(), and $self is available by calling controller().

EXPORTED FUNCTIONS

Top

chain

 1. chain sub { };

 2. chain $PathPart => sub { };
 3. chain $PathPart => $Int, sub { };
 4. chain $PathPart => \@CaptureArgs, sub { };

 5. chain $Chained => $PathPart => sub { };
 6. chain $Chained => $PathPart => $Int, sub { };
 7. chain $Chained => $PathPart => \@CaptureArgs, sub { };

 8. chain ..., \%method_map;

 9. chain ANY => \%extra_args => sub { };

Same as:

 1. sub root : Chained('/') PathPart('') CaptureArgs(0) { }

 2. sub $PathPart : Chained('/root') Args { }
 3. sub $PathPart : Chained('/root') Args($Int) { }
 4. sub $PathPart : Chained('/root') CaptureArgs($Int) { }

 5. sub $PathPart : Chained($Chained) Args { }
 6. sub $PathPart : Chained($Chained) Args($Int) { }
 7. sub $PathPart : Chained($Chained) CaptureArgs($Int) { }

 8. Special case: See below
 9. Special case: See below

@CaptureArgs is a list of names of the captured arguments, which can be retrieved using captured().

$Int is a number of Args to capture at the endpoint of a chain. These cannot be aquired using captured(), but is instead available in @_.

%method_map can be used if you want to dispatch to a specific method, for a certain HTTP method: (The HTTP method is in lowercase)

 %method_map = (
    post => sub { ... },
    get => sub { ... },
    delete => sub { ... },
    default => sub { ... },
    #...
 );

%extra_args can be used to override information. Example:

    { name => 'foo' }

Specifying "name" will replace the default name for this action, with "foo" (or something else).

private

 private $name => sub {};

Same as:

 sub $name :Private {}

forward

 @Any = forward $action;
 @Any = forward $action, \@arguments;

See Catalyst::forward().

go

 go $action;
 go $action, \@arguments;

See Catalyst::go().

c

 $context_obj = c;

Returns the context object for this request, an instance of Catalyst.

controller

 $controller_obj = controller;

Returns the current controller object.

req

 $request_obj = req;

Returns the request object for this request, an instance of Catalyst::Request.

res

 $response_obj = res;

Returns the response object for this request, an instance of Catalyst::Response.

captured

 $value = captured($name);

Retrieve data captured in a chain, using the names set with chain().

 chain '/' => 'user' => ['id'], sub {
   res->body( captured('id') );
 };

stash

 $value = stash $key;
 $hash_ref = stash $key => $value, ...;
 $hash_ref = stash;

Set/get data from the stash. The $hash_ref is a reference to what the stash is holding.

This will be the same as:

 $c->stash->{$key} = $value;

session

 $value = session $key;
 $hash_ref == session $key => $value;
 $hash_ref == session;

Set/get data from the session. The $hash_ref is a reference to what the session is holding.

This function will only work if a session module/plugin is loaded into Catalyst.

report

 report $level, $format, @args;

Almost the same as:

 $c->log->$level(sprintf $format, @args);

But undef values from @args are turned into "__UNDEF__", and objects and/or datastructructures are flatten, using Data::Dumper.

METHODS

init_meta

See Moose::Exporter.

BUGS

Top

Please report any bugs or feature requests to bug-catalystx-controller-sugar at rt.cpan.org. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

COPYRIGHT & LICENSE

Top

Copyright 2007 Jan Henning Thorsen, all rights reserved.

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

AUTHOR

Top

Jan Henning Thorsen, <jhthorsen at cpan.org>

CatalystX-Controller-Sugar documentation Contained in the CatalystX-Controller-Sugar distribution. 
package CatalystX::Controller::Sugar;


use Moose;
use Moose::Exporter;
use namespace::autoclean ();
use Catalyst::Controller ();
use Catalyst::Utils;
use Data::Dumper ();

Moose::Exporter->setup_import_methods(
    with_meta => [qw/ chain private /],
    as_is => [qw/ c captured controller forward go req report res session stash /],
    also => 'Moose',
);

our $VERSION = eval '0.0901';
our $ROOT = 'root'; # will be deprecated
our $DEFAULT = 'default'; # will be deprecated
our($RES, $REQ, $SELF, $CONTEXT, %CAPTURED);


sub chain {
    my $meta = shift;
    my $code = pop;
    my $extra_args = (@_ and ref $_[-1] eq 'HASH') ? pop : {};
    my @chain_args = @_;
    my $class = $meta->name;
    my($name, $action);

    my $c = Catalyst::Utils::class2appclass($class);
    my $namespace = $class->action_namespace($c) || q();
    my $attributes = _setup_chain_attributes($namespace, @chain_args);

    if(defined $extra_args->{'name'}) {
        $name = $extra_args->{'name'};
    }
    else {
        my $path = _path_from_chain_attributes($attributes);
        $name = $extra_args->{'name'} || _name_from_chain_attributes($attributes, $namespace, $path, $c);
    }

    $code = _create_chain_code($class, $code);
    $action = $class->create_action(
                  name => $name,
                  code => $code,
                  reverse => $namespace ? "$namespace/$name" : $name,
                  namespace => $namespace,
                  class => $class,
                  attributes => $attributes,
              );

    $c->dispatcher->register($c, $action);
}

sub _path_from_chain_attributes {
    my $attributes = shift;
    my $path = $attributes->{'Chained'}[0];

    $path =~ s,$ROOT$,,;
    $path .= $attributes->{'PathPart'}[0];

    return $path;
}

sub _name_from_chain_attributes {
    my($attributes, $namespace, $path, $c) = @_;
    my $name;

    if($path ne "/$namespace") {
        $name = (split "/", $attributes->{'PathPart'}[0])[-1];
    }
    elsif($c->dispatcher->get_action($ROOT, $namespace)) {
        $name = $DEFAULT;
    }
    else {
        $name = $ROOT;
    }

    if(@{ $attributes->{'capture_names'} }) { # add captures to name
        $name ||= q();
        $name  .= ":" .int @{ $attributes->{'capture_names'} };
    }
    elsif($attributes->{'Args'} and $attributes->{'Args'}[0]) { # add captures to name
        $name ||= $DEFAULT;
        $name .= "." .$attributes->{'Args'}[0];
    }
    elsif(!$name) { # set default name -- is this correct?
        $name = $DEFAULT;
    }

    return $name;
}

sub _setup_chain_attributes {
    my $namespace = shift;
    my $attributes = {};

    if(@_) { # chain ... => sub {};
        if(ref $_[-1] eq 'ARRAY') {
            $attributes->{'CaptureArgs'} = [int @{ $_[-1] }];
            $attributes->{'capture_names'} = pop @_;
        }
        elsif(defined $_[-1] and $_[-1] =~ /^(\d+)$/) {
            $attributes->{'Args'} = [pop @_];
        }

        if(defined $_[-1]) {
            $attributes->{'PathPart'} = [pop @_];
        }
        else {
            my $args = join ", ", @_;
            confess "Invalid arguments: chain($args)";
        }

        if(defined $_[-1]) {
            my $with = pop @_;
            $attributes->{'Chained'} = [ $with =~ m,^/, ? $with
                                  : $namespace     ? "/$namespace/$with"
                                  :                  "/$with"
                                  ];
        }
        else {
            $attributes->{'Chained'} = [$namespace ? "/$namespace/$ROOT" : "/$ROOT"];
        }
    }
    else { # chain sub {};
        my($parent, $this) = $namespace =~ m[ ^ (.*)/([\w-]+) $ ]x;
        my $chained = $parent    ? "/$parent/$ROOT"
                    : $namespace ? "/$ROOT"
                    :              "/";

        $attributes->{'Chained'}     = [$chained];
        $attributes->{'PathPart'}    = [$this || $namespace];
        $attributes->{'CaptureArgs'} = [0];
    }

    $attributes->{'Args'} ||= [] unless($attributes->{'CaptureArgs'});
    $attributes->{'capture_names'} ||= [];

    return $attributes;
}

sub _create_chain_code {
    my($class, $code) = @_;

    if(ref $code eq 'HASH') {
        return sub {
            local $SELF     = shift;
            local $CONTEXT  = shift;
            local $RES      = $CONTEXT->res;
            local $REQ      = $CONTEXT->req;
            local %CAPTURED = _setup_captured();
            my $method      = lc $REQ->method;

            if($code->{$method}) {
                return $code->{$method}->(@_);
            }
            elsif($code->{'default'}) {
                return $code->{'default'}->(@_);
            }
            else {
                confess "Invalid arguments: chain(.., { '$method' => undef })";
            }
        };
    }
    else {
        return sub {
            local $SELF     = shift;
            local $CONTEXT  = shift;
            local $RES      = $CONTEXT->res;
            local $REQ      = $CONTEXT->req;
            local %CAPTURED = _setup_captured();

            return $code->(@_);
        };
    }
}

sub _setup_captured {
    my @names;

    for my $action (@{ $CONTEXT->action->chain }) {
        push @names, @{ $action->attributes->{'capture_names'} };
    }

    return map { shift(@names), $_ } @{ $REQ->captures };
}


sub private {
    my($meta, $name, $code) = @_;
    my $class = $meta->name;
    my($c, $namespace);
 
    $c = Catalyst::Utils::class2appclass($class);
    $namespace = $class->action_namespace($c);

    $c->dispatcher->register($c,
        $class->create_action(
            name => $name,
            code => _create_private_code($class, $code),
            reverse => $namespace ? "$namespace/$name" : $name,
            namespace => $namespace,
            class => $class,
            attributes => { Private => [] },
        )
    );
}

sub _create_private_code {
    my($class, $code) = @_;

    return sub {
        local $SELF    = shift;
        local $CONTEXT = shift;
        local $RES     = $CONTEXT->res;
        local $REQ     = $CONTEXT->req;

        return $code->(@_);
    };
}


sub forward { $CONTEXT->forward(@_) }
sub go { $CONTEXT->go(@_) }


sub c { $CONTEXT }
sub controller { $SELF }
sub req { $REQ }
sub res { $RES }


sub captured {
    return $CAPTURED{$_[0]};
}


sub stash {
    my $c = $CONTEXT || _get_context_object();

    if(@_ == 1) {
        return $c->stash->{$_[0]};
    }
    elsif(@_ % 2 == 0) {
        while(@_) {
            my($key, $value) = splice @_, 0, 2;
            $c->stash->{$key} = $value;
        }
    }

    return $c->stash;
}


sub session {
    my $c = $CONTEXT || _get_context_object();

    if(@_ == 1) {
        return $c->session->{$_[0]};
    }
    elsif(@_ % 2 == 0) {
        while(@_) {
            my($key, $value) = splice @_, 0, 2;
            $c->session->{$key} = $value;
        }
    }
    else {
        my $args = join ", ", @_;
        confess "Invalid arguments: session($args)";
    }

    return $c->session;
}

sub _get_context_object {
    package DB;
    () = caller(2);
    return $DB::args[1];
}


sub report {
    my $level = shift;
    my $format = shift;
    my $c = $CONTEXT || _get_context_object();
    my $log = $c->log;

    if(my $check = $log->can("is_$level")) {
        if(!$log->$check) {
            return;
        }
    }
    
    return $log->$level(sprintf $format, _flatten(@_));
}

sub _flatten {
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 4;
    local $Data::Dumper::Terse = 0;

    map {
          ref $_     ? Data::Dumper::Dumper($_)
        : defined $_ ? $_
        :              '__UNDEF__'
    } @_;
}


sub init_meta {
    my $c = shift;
    my %options = @_;

    Moose->init_meta(%options);

    $options{'for_class'}->meta->superclasses(qw/Catalyst::Controller/);

    namespace::autoclean->import(-cleanee => $options{'for_class'});

    return $options{'for_class'}->meta;
}


1;