lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use attributes ();
   5 use Catalyst::Exception;
   6 use HTTP::Request;
   7 use Path::Class;
   8 use URI;
   9
  10 =head1 NAME
  11
  12 Catalyst::Utils - The Catalyst Utils
  13
  14 =head1 SYNOPSIS
  15
  16 See L<Catalyst>.
  17
  18 =head1 DESCRIPTION
  19
  20 =head1 METHODS
  21
  22 =over 4
  23
  24 =item attrs($coderef)
  25
  26 Returns attributes for coderef in a arrayref
  27
  28 =cut
  29
  30 sub attrs { attributes::get( $_[0] ) || [] }
  31
  32 =item class2appclass($class);
  33
  34 Returns the appclass for class.
  35
  36     MyApp::C::Foo::Bar becomes MyApp
  37     My::App::C::Foo::Bar becomes My::App
  38
  39 =cut
  40
  41 sub class2appclass {
  42     my $class = shift || '';
  43     my $appname = '';
  44     if ( $class =~ /^(.*)::([MVC]|Model|View|Controller)?::.*$/ ) {
  45         $appname = $1;
  46     }
  47     return $appname;
  48 }
  49
  50 =item class2classprefix($class);
  51
  52 Returns the classprefix for class.
  53
  54     MyApp::C::Foo::Bar becomes MyApp::C
  55     My::App::C::Foo::Bar becomes My::App::C
  56
  57 =cut
  58
  59 sub class2classprefix {
  60     my $class = shift || '';
  61     my $prefix;
  62     if ( $class =~ /^(.*::[MVC]|Model|View|Controller)?::.*$/ ) {
  63         $prefix = $1;
  64     }
  65     return $prefix;
  66 }
  67
  68 =item class2classsuffix($class);
  69
  70 Returns the classsuffix for class.
  71
  72     MyApp::C::Foo::Bar becomes C::Foo::Bar
  73
  74 =cut
  75
  76 sub class2classsuffix {
  77     my $class = shift || '';
  78     my $prefix = class2appclass($class) || '';
  79     $class =~ s/$prefix\:\://;
  80     return $class;
  81 }
  82
  83 =item class2env($class);
  84
  85 Returns the enviroment name for class.
  86
  87     MyApp becomes MYAPP
  88     My::App becomes MY_APP
  89
  90 =cut
  91
  92 sub class2env {
  93     my $class = shift || '';
  94     my $class =~ s/\:\:/_/g;
  95     return uc($class);
  96 }
  97
  98 =item class2prefix( $class, $case );
  99
 100 Returns the prefix for class.
 101
 102     My::App::C::Foo::Bar becomes /foo/bar
 103
 104 =cut
 105
 106 sub class2prefix {
 107     my $class = shift || '';
 108     my $case  = shift || 0;
 109     my $prefix;
 110     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 111         $prefix = $case ? $2 : lc $2;
 112         $prefix =~ s/\:\:/\//g;
 113     }
 114     return $prefix;
 115 }
 116
 117 =item home($class)
 118
 119 Returns home directory for given class.
 120
 121 =cut
 122
 123 sub home {
 124     my $name = shift;
 125     $name =~ s/\:\:/\//g;
 126     my $home = 0;
 127     if ( my $path = $INC{"$name.pm"} ) {
 128         $home = file($path)->absolute->dir;
 129         $name =~ /(\w+)$/;
 130         my $append = $1;
 131         my $subdir = dir($home)->subdir($append);
 132         for ( split '/', $name ) { $home = dir($home)->parent }
 133         if ( $home =~ /blib$/ ) { $home = dir($home)->parent }
 134         elsif (!-f file( $home, 'Makefile.PL' )
 135             && !-f file( $home, 'Build.PL' ) )
 136         {
 137             $home = $subdir;
 138         }
 139         # clean up relative path:
 140         # MyApp/script/.. -> MyApp
 141         my ($lastdir) = $home->dir_list( -1, 1 );
 142         if ( $lastdir eq '..' ) {
 143             $home = dir($home)->parent->parent;
 144         }
 145     }
 146     return $home;
 147 }
 148
 149 =item prefix($class, $name);
 150
 151 Returns a prefixed action.
 152
 153     MyApp::C::Foo::Bar, yada becomes /foo/bar/yada
 154
 155 =cut
 156
 157 sub prefix {
 158     my ( $class, $name ) = @_;
 159     my $prefix = &class2prefix($class);
 160     $name = "$prefix/$name" if $prefix;
 161     return $name;
 162 }
 163
 164 =item reflect_actions($class);
 165
 166 Returns an arrayref containing all actions of a component class.
 167
 168 =cut
 169
 170 sub reflect_actions {
 171     my $class   = shift;
 172     my $actions = [];
 173     eval '$actions = $class->_action_cache';
 174
 175     if ( $@ ) {
 176         Catalyst::Exception->throw(
 177             message => qq/Couldn't reflect actions of component "$class", "$@"/
 178         );
 179     }
 180
 181     return $actions;
 182 }
 183
 184 =item request($string);
 185
 186 Returns an C<HTTP::Request> from a string.
 187
 188 =cut
 189
 190 sub request {
 191     my $request = shift;
 192
 193     unless ( ref $request ) {
 194
 195         if ( $request =~ m/http/i ) {
 196             $request = URI->new($request)->canonical;
 197         }
 198         else {
 199             $request = URI->new( 'http://localhost' . $request )->canonical;
 200         }
 201     }
 202
 203     unless ( ref $request eq 'HTTP::Request' ) {
 204         $request = HTTP::Request->new( 'GET', $request );
 205     }
 206
 207     return $request;
 208 }
 209
 210 =back
 211
 212 =head1 AUTHOR
 213
 214 Sebastian Riedel, C<sri@cpan.org>
 215
 216 =head1 COPYRIGHT
 217
 218 This program is free software, you can redistribute it and/or modify it under
 219 the same terms as Perl itself.
 220
 221 =cut
 222
 223 1;