lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use attributes ();
   5 use Path::Class;
   6
   7 =head1 NAME
   8
   9 Catalyst::Utils - The Catalyst Utils
  10
  11 =head1 SYNOPSIS
  12
  13 See L<Catalyst>.
  14
  15 =head1 DESCRIPTION
  16
  17 =head1 METHODS
  18
  19 =over 4
  20
  21 =item attrs($coderef)
  22
  23 Returns attributes for coderef in a arrayref
  24
  25 =cut
  26
  27 sub attrs { attributes::get( $_[0] ) || [] }
  28
  29 =item class2appclass($class);
  30
  31 Returns the appclass for class.
  32
  33     MyApp::C::Foo::Bar becomes MyApp
  34     My::App::C::Foo::Bar becomes My::App
  35
  36 =cut
  37
  38 sub class2appclass {
  39     my $class = shift || '';
  40     my $appname = '';
  41     if ( $class =~ /^(.*)::([MVC]|Model|View|Controller)?::.*$/ ) {
  42         $appname = $1;
  43     }
  44     return $appname;
  45 }
  46
  47 =item class2classprefix($class);
  48
  49 Returns the classprefix for class.
  50
  51     MyApp::C::Foo::Bar becomes MyApp::C
  52     My::App::C::Foo::Bar becomes My::App::C
  53
  54 =cut
  55
  56 sub class2classprefix {
  57     my $class = shift || '';
  58     my $prefix;
  59     if ( $class =~ /^(.*::[MVC]|Model|View|Controller)?::.*$/ ) {
  60         $prefix = $1;
  61     }
  62     return $prefix;
  63 }
  64
  65 =item class2classsuffix($class);
  66
  67 Returns the classsuffix for class.
  68
  69     MyApp::C::Foo::Bar becomes C::Foo::Bar
  70
  71 =cut
  72
  73 sub class2classsuffix {
  74     my $class = shift || '';
  75     my $prefix = class2appclass($class) || '';
  76     $class =~ s/$prefix\:\://;
  77     return $class;
  78 }
  79
  80 =item class2prefix($class);
  81
  82 Returns the prefix for class.
  83
  84     My::App::C::Foo::Bar becomes /foo/bar
  85
  86 =cut
  87
  88 sub class2prefix {
  89     my $class = shift || '';
  90     my $prefix;
  91     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
  92         $prefix = lc $2;
  93         $prefix =~ s/\:\:/\//g;
  94     }
  95     return $prefix;
  96 }
  97
  98 =item home($class)
  99
 100 Returns home directory for given class.
 101
 102 =cut
 103
 104 sub home {
 105     my $name = shift;
 106     $name =~ s/\:\:/\//g;
 107     my $home = 0;
 108     if ( my $path = $INC{"$name.pm"} ) {
 109         $home = file($path)->absolute->dir;
 110         $name =~ /(\w+)$/;
 111         my $append = $1;
 112         my $subdir = dir($home)->subdir($append);
 113         for ( split '/', $name ) { $home = dir($home)->parent }
 114         if ( $home =~ /blib$/ ) { $home = dir($home)->parent }
 115         elsif ( !-f file( $home, 'Makefile.PL' ) ) { $home = $subdir }
 116     }
 117     return $home;
 118 }
 119
 120 =item prefix($class, $name);
 121
 122 Returns a prefixed action.
 123
 124     MyApp::C::Foo::Bar, yada becomes /foo/bar/yada
 125
 126 =cut
 127
 128 sub prefix {
 129     my ( $class, $name ) = @_;
 130     my $prefix = &class2prefix($class);
 131     $name = "$prefix/$name" if $prefix;
 132     return $name;
 133 }
 134
 135 =item reflect_actions($class);
 136
 137 Returns an arrayref containing all actions of a component class.
 138
 139 =cut
 140
 141 sub reflect_actions {
 142     my $class   = shift;
 143     my $actions = [];
 144     eval '$actions = $class->_action_cache';
 145     die qq/Couldn't reflect actions of component "$class", "$@"/ if $@;
 146     return $actions;
 147 }
 148
 149 =back
 150
 151 =head1 AUTHOR
 152
 153 Sebastian Riedel, C<sri@cpan.org>
 154
 155 =head1 COPYRIGHT
 156
 157 This program is free software, you can redistribute it and/or modify it under
 158 the same terms as Perl itself.
 159
 160 =cut
 161
 162 1;