# @(#)$Id: Usul.pm 1181 2012-04-17 19:06:07Z pjf $ package CatalystX::Usul; use strict; use warnings; use namespace::autoclean; use version; our $VERSION = qv( sprintf '0.7.%d', q$Rev: 1181 $ =~ /\d+/gmsx ); use parent qw(CatalystX::Usul::Base CatalystX::Usul::File CatalystX::Usul::Log); use CatalystX::Usul::Constants; use CatalystX::Usul::Functions qw(arg_list is_arrayref is_hashref merge_attributes my_prefix); use CatalystX::Usul::L10N; use Class::Null; use File::Spec; use IPC::SRLock; use Module::Pluggable::Object; use MRO::Compat; use Scalar::Util qw(blessed); my $ATTRS = { config => {}, debug => FALSE, encoding => q(UTF-8), log => Class::Null->new, suid => NUL, tempdir => File::Spec->tmpdir, }; __PACKAGE__->mk_accessors( qw(config debug encoding l10n lock log prefix secret suid tempdir) ); __PACKAGE__->mk_log_methods(); sub new { my ($self, @rest) = @_; my $class = blessed $self || $self; my $new = bless BUILDARGS( q(_arg_list), $class, @rest ), $class; $new->build_attributes( [ qw(prefix secret lock l10n) ] ); return $new; } sub BUILDARGS { my ($next, $class, $app, @rest) = @_; my $attrs = $class->$next( @rest ); __merge_attrs( $attrs, $app || {}, [ qw(config debug log) ] ); __merge_attrs( $attrs, $attrs->{config}, [ qw(encoding suid tempdir) ] ); return $attrs; } sub build_attributes { my ($self, $attrs, $force) = @_; for (@{ $attrs || [] }) { my $builder = q(_build_).$_; ($force or not defined $self->$_) and $self->$_( $self->$builder() ); } return; } sub build_subcomponents { # Voodo by mst. Finds and loads component subclasses my ($self, $base_class) = @_; my $my_class = blessed $self || $self; (my $dir = $self->find_source( $base_class )) =~ s{ [.]pm \z }{}msx; 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 loc { my ($self, $params, $key, @rest) = @_; my $car = $rest[ 0 ]; my $args = (is_hashref $car) ? $car : { params => (is_arrayref $car) ? $car : [ @rest ] }; $args->{domain_names} = [ DEFAULT_L10N_DOMAIN, $params->{ns} ]; $args->{locale } = $params->{lang}; return $self->l10n->localize( $key, $args ); } sub setup_plugins { # Searches for and then loads plugins in the search path my ($class, $config) = @_; my $child_class = delete $config->{child_class } || $class; my $exclude = delete $config->{exclude_pattern} || q(\A \z); my @paths = @{ delete $config->{search_paths} || [] }; my $spath = [ map { m{ \A :: }msx ? __PACKAGE__.$_ : $_ } @paths ]; my $finder = Module::Pluggable::Object->new ( search_path => $spath, %{ $config } ); my @plugins = grep { not m{ $exclude }msx } sort { length $a <=> length $b } $finder->plugins; $class->_load_component( $child_class, @plugins ); return \@plugins; } sub supports { my ($self, @spec) = @_; my $cursor = eval { $self->get_features } || {}; @spec == 1 and exists $cursor->{ $spec[ 0 ] } and return TRUE; # Traverse the feature list for (@spec) { ref $cursor eq HASH or return FALSE; $cursor = $cursor->{ $_ }; } ref $cursor or return $cursor; ref $cursor eq ARRAY or return FALSE; # Check that all the keys required for a feature are in here for (@{ $cursor }) { exists $self->{ $_ } or return FALSE } return TRUE; } # Private methods sub _arg_list { my $self = shift; return arg_list @_; } sub _build_l10n { my $self = shift; my $cfg = $self->config; my $attrs = arg_list $cfg->{l10n_attrs}; __merge_attrs( $attrs, $self, [ qw(debug lock log tempdir) ] ); defined $cfg->{localedir} and $attrs->{localedir} ||= $cfg->{localedir}; return CatalystX::Usul::L10N->new( $attrs ); } sub _build_lock { # There is only one lock object. Instantiate on first use my $self = shift; my $lock; $lock = __PACKAGE__->get_inherited( q(lock) ) and return $lock; my $attrs = arg_list $self->config->{lock_attrs}; __merge_attrs( $attrs, $self, [ qw(debug log tempdir) ] ); return __PACKAGE__->set_inherited( q(lock), IPC::SRLock->new( $attrs ) ); } sub _build_prefix { my $self = shift; return $self->config->{prefix} || my_prefix $self->suid; } sub _build_secret { my $self = shift; return $self->config->{secret} || $self->prefix; } sub _load_component { my ($self, $child, @parents) = @_; ## no critic for my $parent (reverse @parents) { $self->ensure_class_loaded( $parent ); { no strict q(refs); $child eq $parent or $child->isa( $parent ) or unshift @{ "${child}::ISA" }, $parent; } } exists $Class::C3::MRO{ $child } or eval "package $child; import Class::C3;"; ## critic return; } # Private subroutines sub __merge_attrs { return merge_attributes $_[ 0 ], $_[ 1 ], $ATTRS, $_[ 2 ]; } 1; __END__ =pod =head1 Name CatalystX::Usul - A base class for Catalyst MVC components =head1 Version This document describes CatalystX::Usul version 0.7.$Revision: 1181 $ =head1 Synopsis use parent qw(CatalystX::Usul); =head1 Description These modules provide a set of base classes for a Catalyst web application. Features include: =over 3 =item Targeted at intranet applications The identity model supports multiple backend authentication stores including the underlying operating system accounts =item Thin controllers Most controllers make a single call to the model and so comprise of only a few lines of code. The interface model stashes data used by the view to render the page =item No further view programing required A single L<template tookit|Template::Toolkit> instance is used to render all pages as either HTML or XHTML. The template forms one component of the "skin", the other components are: a Javascript file containing the use cases for the Javascript libraries, a primary CSS file with support for alternative CSS files, and a set of image files Designers can create new skins with different layout, presentation and behaviour for the whole application. They can do this for the example application, L<Munchies|App::Munchies>, whilst the programmers write the "real" application in parallel with the designers work =item Flexable development methodology These base classes are used by an example application, L<Munchies|App::Munchies>, which can be deployed to staging and production servers at the beginning of the project. Setting up the example application allows issues regarding the software technology to be resolved whilst the "real" application is being written. The example application can be deleted leaving these base classes for the "real" application to use =back =head1 Configuration and Environment Catalyst will set the C<$config> argument passed to the constructor to the section of the configuration appropriate for the component being initialised =head1 Subroutines/Methods This module provides methods common to C<controllers|CatalystX::Usul::Controller> and C<models|CatalystX::Usul::Model> which both inherit from this class. This means that you should probably inherit from one of them instead =head2 new $self = CatalystX::Usul->new( $app, $attrs ); Constructor. Inherits from the L<base|CatalystX::Usul::Base> and the L<encoding|CatalystX::Usul::Encoding> classes. The L<Catalyst|Catalyst> application context is C<$app> and C<$attrs> is a hash ref containing the object attributes. Defines the following attributes: =over 3 =item config Hash of attributes read from the config file =item debug The application context debug is used to set this. Defaults to false =item encoding Which character encoding to use, defaults to C<UTF-8> =item lock The lock object. This is readonly and instantiates on first use =item log The application context log. Defaults to a L<null|Class::Null> object =item prefix The prefix applied to executable programs in the I<bin> directory. This is extracted from the I<suid> key in the config hash =item secret This applications secret key as set by the administrators in the configuration. It is used to perturb the encryption methods. Defaults to the I<prefix> attribute value =item suid Supplied by the config hash, it is the name of the setuid root program in the I<bin> directory. Defaults to the null string =item tempdir Location of any temporary files created by the application. Defaults to the L<system|File::Spec> tempdir =back =head2 BUILDARGS Preprocesses the are passed to the constructor =head2 build_attributes $self->build_attributes( [ qw(a list of attributes names) ], $force ); For each attribute in the list, if it is undefined or C<$force> is true, this method calls the builder method C<_build_attribute_name> and sets the attribute with the result =head2 build_subcomponents __PACKAGE__->build_subcomponents( $base_class ); Class method that allows us to define components that inherit from the base class at runtime =head2 loc $local_text = $self->loc( $args, $key, $params ); Localizes the message. Calls L<CatalystX::Usul::L10N/localize> =head2 setup_plugins @plugins = __PACKAGE__->setup_plugins( $config_ref ); Load the given list of plugins and have the supplied class inherit from them. Returns an array ref of available plugins =head2 supports $bool = $self->supports( @spec ); Returns true if the hash returned by our I<get_features> attribute contains all the elements of the required specification =head2 _build_lock A L<lock|IPC::SRLock> object which is used to single thread the application where required. This is a singleton object. Provides defaults for and returns a new L<set/reset|IPC::SRLock> lock object. The keys of the C<$attrs> hash are: =over 3 =item debug Debug status. Defaults to C<< $self->debug >> =item log Logging object. Defaults to C<< $self->log >> =item tempdir Directory used to store the lock file and lock table if the C<fcntl> backend is used. Defaults to C<< $self->tempdir >> =back =head2 _load_component $self->_load_component( $child, @parents ); Ensures that each component is loaded then fixes @ISA for the child so that it inherits from the parents =head1 Diagnostics Setting the I<debug> attribute to true causes messages to be logged at the debug level =head1 Dependencies =over 3 =item L<CatalystX::Usul::Base> =item L<CatalystX::Usul::Constants> =item L<CatalystX::Usul::File> =item L<CatalystX::Usul::Functions> =item L<CatalystX::Usul::L10N> =item L<CatalystX::Usul::Log> =item L<IPC::SRLock> =item L<Module::Pluggable::Object> =back To make the Captchas work L<GD::SecurityImage> needs to be installed which has a documented dependency on C<libgd> which should be installed first =head1 Incompatibilities There are no known incompatibilities in this module =head1 Bugs and Limitations There are no known bugs in this module. Please report problems to the address below. Patches are welcome =head1 Author Peter Flanigan, C<< <Support at RoxSoft.co.uk> >> =head1 Acknowledgements Larry Wall - For the Perl programming language =head1 License and Copyright Copyright (c) 2012 Peter Flanigan. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See the L<Perl Artistic License|perlartistic> This program is distributed in the hope that it will be useful, but WITHOUT WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE =cut # Local Variables: # mode: perl # tab-width: 3 # End: