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
  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             my $home = dir($path)->absolute->cleanup;
 164
 165             # pop off /lib and /blib if they're there
 166             $home = $home->parent while $home =~ /b?lib$/;
 167
 168             # only return the dir if it has a Makefile.PL or Build.PL
 169             if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
 170
 171                 # clean up relative path:
 172                 # MyApp/script/.. -> MyApp
 173
 174                 my $dir;
 175                 my @dir_list = $home->dir_list();
 176                 while (($dir = pop(@dir_list)) && $dir eq '..') {
 177                     $home = dir($home)->parent->parent;
 178                 }
 179
 180                 return $home->stringify;
 181             }
 182         }
 183
 184         {
 185             # look for an installed Catalyst app
 186
 187             # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
 188             ( my $path = $inc_entry) =~ s/\.pm$//;
 189             my $home = dir($path)->absolute->cleanup;
 190
 191             # return if if it's a valid directory
 192             return $home->stringify if -d $home;
 193         }
 194     }
 195
 196     # we found nothing
 197     return 0;
 198 }
 199
 200 =head2 prefix($class, $name);
 201
 202 Returns a prefixed action.
 203
 204     MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
 205
 206 =cut
 207
 208 sub prefix {
 209     my ( $class, $name ) = @_;
 210     my $prefix = &class2prefix($class);
 211     $name = "$prefix/$name" if $prefix;
 212     return $name;
 213 }
 214
 215 =head2 request($uri)
 216
 217 Returns an L<HTTP::Request> object for a uri.
 218
 219 =cut
 220
 221 sub request {
 222     my $request = shift;
 223     unless ( ref $request ) {
 224         if ( $request =~ m/^http/i ) {
 225             $request = URI->new($request);
 226         }
 227         else {
 228             $request = URI->new( 'http://localhost' . $request );
 229         }
 230     }
 231     unless ( ref $request eq 'HTTP::Request' ) {
 232         $request = HTTP::Request->new( 'GET', $request );
 233     }
 234     return $request;
 235 }
 236
 237 =head2 ensure_class_loaded($class_name, \%opts)
 238
 239 Loads the class unless it already has been loaded.
 240
 241 If $opts{ignore_loaded} is true always tries the require whether the package
 242 already exists or not. Only pass this if you're either (a) sure you know the
 243 file exists on disk or (b) have code to catch the file not found exception
 244 that will result if it doesn't.
 245
 246 =cut
 247
 248 sub ensure_class_loaded {
 249     my $class = shift;
 250     my $opts  = shift;
 251
 252     croak "Malformed class Name $class"
 253         if $class =~ m/(?:\b\:\b|\:{3,})/;
 254
 255     croak "Malformed class Name $class"
 256         if $class =~ m/[^\w:]/;
 257
 258     croak "ensure_class_loaded should be given a classname, not a filename ($class)"
 259         if $class =~ m/\.pm$/;
 260
 261     return if !$opts->{ ignore_loaded }
 262         && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again
 263
 264     # this hack is so we don't overwrite $@ if the load did not generate an error
 265     my $error;
 266     {
 267         local $@;
 268         my $file = $class . '.pm';
 269         $file =~ s{::}{/}g;
 270         eval { CORE::require($file) };
 271         $error = $@;
 272     }
 273
 274     die $error if $error;
 275     die "require $class was successful but the package is not defined"
 276         unless Class::Inspector->loaded($class);
 277
 278     return 1;
 279 }
 280
 281 =head2 merge_hashes($hashref, $hashref)
 282
 283 Base code to recursively merge two hashes together with right-hand precedence.
 284
 285 =cut
 286
 287 sub merge_hashes {
 288     my ( $lefthash, $righthash ) = @_;
 289
 290     return $lefthash unless defined $righthash;
 291
 292     my %merged = %$lefthash;
 293     for my $key ( keys %$righthash ) {
 294         my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
 295         my $left_ref  = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
 296         if( $right_ref and $left_ref ) {
 297             $merged{ $key } = merge_hashes(
 298                 $lefthash->{ $key }, $righthash->{ $key }
 299             );
 300         }
 301         else {
 302             $merged{ $key } = $righthash->{ $key };
 303         }
 304     }
 305
 306     return \%merged;
 307 }
 308
 309 =head2 env_value($class, $key)
 310
 311 Checks for and returns an environment value. For instance, if $key is
 312 'home', then this method will check for and return the first value it finds,
 313 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
 314
 315 =cut
 316
 317 sub env_value {
 318     my ( $class, $key ) = @_;
 319
 320     $key = uc($key);
 321     my @prefixes = ( class2env($class), 'CATALYST' );
 322
 323     for my $prefix (@prefixes) {
 324         if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
 325             return $value;
 326         }
 327     }
 328
 329     return;
 330 }
 331
 332 =head1 AUTHOR
 333
 334 Sebastian Riedel, C<sri@cpan.org>
 335 Yuval Kogman, C<nothingmuch@woobling.org>
 336
 337 =head1 COPYRIGHT
 338
 339 This program is free software, you can redistribute it and/or modify it under
 340 the same terms as Perl itself.
 341
 342 =cut
 343
 344 1;