lib/Catalyst/Utils.pm

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