lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use Catalyst::Exception;
   5 use File::Spec;
   6 use HTTP::Request;
   7 use Path::Class;
   8 use URI;
   9 use Class::Inspector;
  10 use Carp qw/croak/;
  11 use Cwd;
  12
  13 =head1 NAME
  14
  15 Catalyst::Utils - The Catalyst Utils
  16
  17 =head1 SYNOPSIS
  18
  19 See L<Catalyst>.
  20
  21 =head1 DESCRIPTION
  22
  23 =head1 METHODS
  24
  25 =head2 appprefix($class)
  26
  27     MyApp::Foo becomes myapp_foo
  28
  29 =cut
  30
  31 sub appprefix {
  32     my $class = shift;
  33     $class =~ s/::/_/g;
  34     $class = lc($class);
  35     return $class;
  36 }
  37
  38 =head2 class2appclass($class);
  39
  40     MyApp::Controller::Foo::Bar becomes MyApp
  41     My::App::Controller::Foo::Bar becomes My::App
  42
  43 =cut
  44
  45 sub class2appclass {
  46     my $class = shift || '';
  47     my $appname = '';
  48     if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
  49         $appname = $1;
  50     }
  51     return $appname;
  52 }
  53
  54 =head2 class2classprefix($class);
  55
  56     MyApp::Controller::Foo::Bar becomes MyApp::Controller
  57     My::App::Controller::Foo::Bar becomes My::App::Controller
  58
  59 =cut
  60
  61 sub class2classprefix {
  62     my $class = shift || '';
  63     my $prefix;
  64     if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
  65         $prefix = $1;
  66     }
  67     return $prefix;
  68 }
  69
  70 =head2 class2classsuffix($class);
  71
  72     MyApp::Controller::Foo::Bar becomes Controller::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 =head2 class2env($class);
  84
  85 Returns the environment 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     $class =~ s/::/_/g;
  95     return uc($class);
  96 }
  97
  98 =head2 class2prefix( $class, $case );
  99
 100 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
 101
 102     My::App::Controller::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 =head2 class2tempdir( $class [, $create ] );
 118
 119 Returns a tempdir for a class. If create is true it will try to create the path.
 120
 121     My::App becomes /tmp/my/app
 122     My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
 123
 124 =cut
 125
 126 sub class2tempdir {
 127     my $class  = shift || '';
 128     my $create = shift || 0;
 129     my @parts = split '::', lc $class;
 130
 131     my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
 132
 133     if ( $create && !-e $tmpdir ) {
 134
 135         eval { $tmpdir->mkpath };
 136
 137         if ($@) {
 138             Catalyst::Exception->throw(
 139                 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
 140         }
 141     }
 142
 143     return $tmpdir->stringify;
 144 }
 145
 146 =head2 home($class)
 147
 148 Returns home directory for given class.
 149
 150 =cut
 151
 152 sub home {
 153     my $class = shift;
 154
 155     # make an $INC{ $key } style string from the class name
 156     (my $file = "$class.pm") =~ s{::}{/}g;
 157
 158     if ( my $inc_entry = $INC{$file} ) {
 159         {
 160             # look for an uninstalled Catalyst app
 161
 162             # find the @INC entry in which $file was found
 163             (my $path = $inc_entry) =~ s/$file$//;
 164             $path ||= cwd() if !defined $path || !length $path;
 165             my $home = dir($path)->absolute->cleanup;
 166
 167             # pop off /lib and /blib if they're there
 168             $home = $home->parent while $home =~ /b?lib$/;
 169
 170             # only return the dir if it has a Makefile.PL or Build.PL
 171             if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
 172
 173                 # clean up relative path:
 174                 # MyApp/script/.. -> MyApp
 175
 176                 my $dir;
 177                 my @dir_list = $home->dir_list();
 178                 while (($dir = pop(@dir_list)) && $dir eq '..') {
 179                     $home = dir($home)->parent->parent;
 180                 }
 181
 182                 return $home->stringify;
 183             }
 184         }
 185
 186         {
 187             # look for an installed Catalyst app
 188
 189             # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
 190             ( my $path = $inc_entry) =~ s/\.pm$//;
 191             my $home = dir($path)->absolute->cleanup;
 192
 193             # return if if it's a valid directory
 194             return $home->stringify if -d $home;
 195         }
 196     }
 197
 198     # we found nothing
 199     return 0;
 200 }
 201
 202 =head2 prefix($class, $name);
 203
 204 Returns a prefixed action.
 205
 206     MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
 207
 208 =cut
 209
 210 sub prefix {
 211     my ( $class, $name ) = @_;
 212     my $prefix = &class2prefix($class);
 213     $name = "$prefix/$name" if $prefix;
 214     return $name;
 215 }
 216
 217 =head2 request($uri)
 218
 219 Returns an L<HTTP::Request> object for a uri.
 220
 221 =cut
 222
 223 sub request {
 224     my $request = shift;
 225     unless ( ref $request ) {
 226         if ( $request =~ m/^http/i ) {
 227             $request = URI->new($request);
 228         }
 229         else {
 230             $request = URI->new( 'http://localhost' . $request );
 231         }
 232     }
 233     unless ( ref $request eq 'HTTP::Request' ) {
 234         $request = HTTP::Request->new( 'GET', $request );
 235     }
 236     return $request;
 237 }
 238
 239 =head2 ensure_class_loaded($class_name, \%opts)
 240
 241 Loads the class unless it already has been loaded.
 242
 243 If $opts{ignore_loaded} is true always tries the require whether the package
 244 already exists or not. Only pass this if you're either (a) sure you know the
 245 file exists on disk or (b) have code to catch the file not found exception
 246 that will result if it doesn't.
 247
 248 =cut
 249
 250 sub ensure_class_loaded {
 251     my $class = shift;
 252     my $opts  = shift;
 253
 254     croak "Malformed class Name $class"
 255         if $class =~ m/(?:\b\:\b|\:{3,})/;
 256
 257     croak "Malformed class Name $class"
 258         if $class =~ m/[^\w:]/;
 259
 260     croak "ensure_class_loaded should be given a classname, not a filename ($class)"
 261         if $class =~ m/\.pm$/;
 262
 263     return if !$opts->{ ignore_loaded }
 264         && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again
 265
 266     # this hack is so we don't overwrite $@ if the load did not generate an error
 267     my $error;
 268     {
 269         local $@;
 270         my $file = $class . '.pm';
 271         $file =~ s{::}{/}g;
 272         eval { CORE::require($file) };
 273         $error = $@;
 274     }
 275
 276     die $error if $error;
 277     die "require $class was successful but the package is not defined"
 278         unless Class::Inspector->loaded($class);
 279
 280     return 1;
 281 }
 282
 283 =head2 merge_hashes($hashref, $hashref)
 284
 285 Base code to recursively merge two hashes together with right-hand precedence.
 286
 287 =cut
 288
 289 sub merge_hashes {
 290     my ( $lefthash, $righthash ) = @_;
 291
 292     return $lefthash unless defined $righthash;
 293
 294     my %merged = %$lefthash;
 295     for my $key ( keys %$righthash ) {
 296         my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
 297         my $left_ref  = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
 298         if( $right_ref and $left_ref ) {
 299             $merged{ $key } = merge_hashes(
 300                 $lefthash->{ $key }, $righthash->{ $key }
 301             );
 302         }
 303         else {
 304             $merged{ $key } = $righthash->{ $key };
 305         }
 306     }
 307
 308     return \%merged;
 309 }
 310
 311 =head2 env_value($class, $key)
 312
 313 Checks for and returns an environment value. For instance, if $key is
 314 'home', then this method will check for and return the first value it finds,
 315 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
 316
 317 =cut
 318
 319 sub env_value {
 320     my ( $class, $key ) = @_;
 321
 322     $key = uc($key);
 323     my @prefixes = ( class2env($class), 'CATALYST' );
 324
 325     for my $prefix (@prefixes) {
 326         if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
 327             return $value;
 328         }
 329     }
 330
 331     return;
 332 }
 333
 334 =head1 AUTHORS
 335
 336 Catalyst Contributors, see Catalyst.pm
 337
 338 =head1 COPYRIGHT
 339
 340 This program is free software, you can redistribute it and/or modify it under
 341 the same terms as Perl itself.
 342
 343 =cut
 344
 345 1;