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