CatalystX::Usul - A base class for Catalyst MVC components

   use base qw(CatalystX::Usul);

   $self = CatalystX::Usul->new( $app, $config );

   __PACKAGE__->build_subcomponents( $base_class );

   $action = $self->get_action( $c, $action_path );

   $local_text = $self->localize( $c, $message, @args );

   @plugins = $self->setup_plugins( $class, $config_ref );

   $uri = $self->uri_for( $c, $action_path, @args );

   $action = $self->_guess_chained_action( $c, $action_path );

   $self->_lock_obj( $args );

# @(#)$Id: Usul.pm 625 2009-06-30 16:32:54Z pjf $

package CatalystX::Usul;

use strict;
use warnings;
use version; our $VERSION = qv( sprintf '0.3.%d', q$Rev: 625 $ =~ /\d+/gmx );
use parent qw(Catalyst::Component CatalystX::Usul::Base);

use Class::C3;
use Class::Null;
use File::Spec;
use IPC::SRLock;
use Module::Pluggable::Object;
use Text::Markdown qw(markdown);

__PACKAGE__->mk_accessors( qw(debug encoding lock log prefix
                              redirect_to secret suid tabstop tempdir) );

my $LSB = q([);
my $NUL = q();
my $SEP = q(/);
my $SPC = q( );

sub new {
   my ($self, $app, $config) = @_; $app ||= Class::Null->new;

   my $ac     = $app->config || {};
   my $new    = $self->next::method( $app, $config );
   my $prefix = (split m{ _ }mx, ($ac->{suid} || $NUL))[0];

   $new->debug      ( $app->debug        || 0                      );
   $new->encoding   ( $ac->{encoding   } || q(UTF-8)               );
   $new->log        ( $app->log          || Class::Null->new       );
   $new->prefix     ( $ac->{prefix     } || $prefix                );
   $new->redirect_to( $ac->{redirect_to} || q(redirect_to_default) );
   $new->secret     ( $ac->{secret     } || $new->prefix           );
   $new->suid       ( $ac->{suid       } || $NUL                   );
   $new->tabstop    ( $ac->{tabstop    } || 3                      );
   $new->tempdir    ( $ac->{tempdir    } || File::Spec->tmpdir     );

   $new->lock( $new->_lock_obj( $ac->{lock} ) );

   return $new;
}

sub build_subcomponents {
   # Voodo by mst. Finds and loads component subclasses
   my ($self, $base_class) = @_; my $my_class = ref $self || $self; my $dir;

   ($dir = $self->find_source( $base_class )) =~ s{ \.pm \z }{}mx;

   for my $path (glob $self->catfile( $dir, q(*.pm) )) {
      my $subcomponent = $self->basename( $path, q(.pm) );
      my $component    = join q(::), $my_class,   $subcomponent;
      my $base         = join q(::), $base_class, $subcomponent;

      $self->load_component( $component, $base );
   }

   return;
}

sub get_action {
   my ($self, $c, $path) = @_; my $action;

   # Normalise the path. It must contain a SEP char
   $path ||= $SEP;
   $path  .= $SEP if ((index $path, $SEP) < 0);

   # Extract the action attributes
   my ($namespace, $name) = split $SEP, $path;

   # Default the namespace and expand the root symbol
   $namespace ||= ($c->action && $c->action->namespace) || $SEP;
   $namespace   = $SEP if ($namespace eq q(root));

   # Default the name if one was not provided
   $name ||= $self->redirect_to;

   # Return the action for this namespace/name pair
   return $action if ($action = $c->get_action( $name, $namespace ));

   my $error = 'No action for [_1]/[_2]';

   $self->log_warn( $self->loc( $c, $error, $namespace, $name ) );
   return;
}

*loc = \&localize;

sub localize {
   my ($self, $c, $key, @rest) = @_; my $s = $c->stash; my @args = ();

   return unless $key;

   $key = q().$key; # Force stringification. I hate Return::Value

   # Lookup the message using the supplied key
   my $messages = $s->{messages} || {};
   my $message  = $messages->{ $key };
   my $text;

   if ($message and $text = $message->{text}) {
      # Optionally call markdown if required
      if ($message->{markdown}) {
         # TODO: Cache copies of this on demand
         my $content_type = $s->{content_type} || q(text/html);
         my $suffix       = $content_type eq q(text/html) ? q(>) : q( />);

         $text = markdown( $text, { empty_element_suffix => $suffix,
                                    tab_width            => $self->tabstop } );
      }
   }
   else { $text = $key } # Default the message text to the key

   if ($rest[ 0 ]) {
      @args = ref $rest[ 0 ] eq q(ARRAY) ? @{ $rest[ 0 ] } : @rest;
   }

   # Expand positional parameters of the form [_<n>]
   if ((index $text, $LSB) >= 0) {
      push @args, map { $NUL } 0 .. 10;
      $text =~ s{ \[ _ (\d+) \] }{$args[ $1 - 1 ]}gmx;
   }

   return $text;
}

sub setup_plugins {
   # Searches for and then load plugins in the search path
   my ($class, $config) = @_;

   my $exclude = delete $config->{ exclude_pattern } || q(\A \z);
   my @paths   = @{ delete $config->{ search_paths } || [] };
   my $finder  = Module::Pluggable::Object->new
      ( search_path => [ map { m{ \A :: }mx ? __PACKAGE__.$_ : $_ } @paths ],
        %{ $config } );
   my @plugins = grep { !m{ $exclude }mx }
                 sort { length $a <=> length $b } $finder->plugins;

   $class->load_component( $class, @plugins );

   return \@plugins;
}

sub uri_for {
   # Code lifted from contextual_uri_for_action
   my ($self, $c, $action_path, @rest) = @_;
   my ($action, @captures, $chained_action, $error, $uri);

   # Get the action for the given action path
   return unless ($action = $self->get_action( $c, $action_path ));

   my $attrs = $action->attributes;

   if (not $attrs->{Chained} or $attrs->{CaptureArgs}) {
      $error = 'Not a chained endpoint [_1]';
      $self->log_warn( $self->loc( $c, $error, $action->reverse ) );
      return;
   }

   my $chained_path = $attrs->{Chained}->[ 0 ]; my @chain = ();

   # Pull out all actions for the chain
   while ($chained_path ne $SEP) {
      $chained_action = $self->_guess_chained_action( $c, $chained_path );
      unshift @chain, $chained_action;
      $chained_path = $chained_action->attributes->{Chained}->[ 0 ];
   }

   my $params = scalar @rest && ref $rest[ -1 ] eq q(HASH) ? pop @rest : $NUL;
   my @args   = @rest;

   # Now start from the root of the chain, populate captures
   for my $num_caps (map { $_->attributes->{CaptureArgs}->[ 0 ] } @chain) {
      if ($num_caps > scalar @args) {
         $error = 'Insufficient args for [_1]';
         $self->log_warn( $self->loc( $c, $error, $action->reverse ) );
         return;
      }

      push @captures, splice @args, 0, $num_caps;
   }

   my $first_arg = $captures[ 0 ] || $args[ 0 ] || $NUL;

   push @args, { %{ $params } } if ($params);

   unless ($uri = $c->uri_for( $action, \@captures, @args )) {
      $self->log_warn( $self->loc( $c, 'No uri for [_1]', $action->reverse ) );
      return;
   }

   return $uri unless ($uri =~ m{ $SEP $SEP $first_arg \z }mx);

   # Fix up result in this edge case
   $uri =~ s{ $SEP $SEP $first_arg \z }{$SEP$first_arg}mx;
   return bless \$uri, ref $c->req->base;
}

# Private methods

sub _guess_chained_action {
   # Returns the action for a given chained midpoint
   my ($self, $c, $path) = @_; my $chained_action;

   if ($Catalyst::VERSION < 5.8) {
      for my $d_type (@{ $c->dispatcher->dispatch_types }) {
         last if ($chained_action = $d_type->{actions}->{ $path });
      }
   }
   else {
      my $d_type = $c->dispatcher->dispatch_type( q(Chained) );

      # Oops, there goes the encapsulation again
      $chained_action = $d_type->{_actions}->{ $path } if ($d_type);
   }

   return $chained_action if ($chained_action);

   my $error = 'Action path [_1] not in a chained endpoint';

   $self->throw( $self->loc( $c, $error, $path ) );
   return;
}

sub _lock_obj {
   my ($self, $args) = @_; my $lock;

   # There is only one lock object
   return $lock if ($lock = __PACKAGE__->get_inherited( q(lock) ));

   $args            ||= {};
   $args->{debug  } ||= $self->debug;
   $args->{log    } ||= $self->log;
   $args->{tempdir} ||= $self->tempdir;

   return __PACKAGE__->set_inherited( q(lock), IPC::SRLock->new( $args ) );
}

1;

__END__

# Local Variables:
# mode: perl
# tab-width: 3
# End: