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