lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use File::Spec;
   5 use HTTP::Request;
   6 use Path::Class;
   7 use URI;
   8 use Carp qw/croak/;
   9 use Cwd;
  10 use Class::MOP;
  11 use String::RewritePrefix;
  12 use Class::Load ();
  13
  14 use namespace::clean;
  15
  16 =head1 NAME
  17
  18 Catalyst::Utils - The Catalyst Utils
  19
  20 =head1 SYNOPSIS
  21
  22 See L<Catalyst>.
  23
  24 =head1 DESCRIPTION
  25
  26 Catalyst Utilities.
  27
  28 =head1 METHODS
  29
  30 =head2 appprefix($class)
  31
  32     MyApp::Foo becomes myapp_foo
  33
  34 =cut
  35
  36 sub appprefix {
  37     my $class = shift;
  38     $class =~ s/::/_/g;
  39     $class = lc($class);
  40     return $class;
  41 }
  42
  43 =head2 class2appclass($class);
  44
  45     MyApp::Controller::Foo::Bar becomes MyApp
  46     My::App::Controller::Foo::Bar becomes My::App
  47
  48 =cut
  49
  50 sub class2appclass {
  51     my $class = shift || '';
  52     my $appname = '';
  53     if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
  54         $appname = $1;
  55     }
  56     return $appname;
  57 }
  58
  59 =head2 class2classprefix($class);
  60
  61     MyApp::Controller::Foo::Bar becomes MyApp::Controller
  62     My::App::Controller::Foo::Bar becomes My::App::Controller
  63
  64 =cut
  65
  66 sub class2classprefix {
  67     my $class = shift || '';
  68     my $prefix;
  69     if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
  70         $prefix = $1;
  71     }
  72     return $prefix;
  73 }
  74
  75 =head2 class2classsuffix($class);
  76
  77     MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
  78
  79 =cut
  80
  81 sub class2classsuffix {
  82     my $class = shift || '';
  83     my $prefix = class2appclass($class) || '';
  84     $class =~ s/$prefix\:://;
  85     return $class;
  86 }
  87
  88 =head2 class2env($class);
  89
  90 Returns the environment name for class.
  91
  92     MyApp becomes MYAPP
  93     My::App becomes MY_APP
  94
  95 =cut
  96
  97 sub class2env {
  98     my $class = shift || '';
  99     $class =~ s/::/_/g;
 100     return uc($class);
 101 }
 102
 103 =head2 class2prefix( $class, $case );
 104
 105 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
 106
 107     My::App::Controller::Foo::Bar becomes foo/bar
 108
 109 =cut
 110
 111 sub class2prefix {
 112     my $class = shift || '';
 113     my $case  = shift || 0;
 114     my $prefix;
 115     if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
 116         $prefix = $case ? $2 : lc $2;
 117         $prefix =~ s{::}{/}g;
 118     }
 119     return $prefix;
 120 }
 121
 122 =head2 class2tempdir( $class [, $create ] );
 123
 124 Returns a tempdir for a class. If create is true it will try to create the path.
 125
 126     My::App becomes /tmp/my/app
 127     My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
 128
 129 =cut
 130
 131 sub class2tempdir {
 132     my $class  = shift || '';
 133     my $create = shift || 0;
 134     my @parts = split '::', lc $class;
 135
 136     my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
 137
 138     if ( $create && !-e $tmpdir ) {
 139
 140         eval { $tmpdir->mkpath };
 141
 142         if ($@) {
 143             # don't load Catalyst::Exception as a BEGIN in Utils,
 144             # because Utils often gets loaded before MyApp.pm, and if
 145             # Catalyst::Exception is loaded before MyApp.pm, it does
 146             # not honor setting
 147             # $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
 148             # MyApp.pm
 149             require Catalyst::Exception;
 150             Catalyst::Exception->throw(
 151                 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
 152         }
 153     }
 154
 155     return $tmpdir->stringify;
 156 }
 157
 158 =head2 home($class)
 159
 160 Returns home directory for given class.
 161
 162 =head2 dist_indicator_file_list
 163
 164 Returns a list of files which can be tested to check if you're inside
 165 a CPAN distribution which is not yet installed.
 166
 167 These are:
 168
 169 =over
 170
 171 =item Makefile.PL
 172
 173 =item Build.PL
 174
 175 =item dist.ini
 176
 177 =item L<cpanfile>
 178
 179 =back
 180
 181 =cut
 182
 183 sub dist_indicator_file_list {
 184     qw{Makefile.PL Build.PL dist.ini cpanfile};
 185 }
 186
 187 sub home {
 188     my $class = shift;
 189
 190     # make an $INC{ $key } style string from the class name
 191     (my $file = "$class.pm") =~ s{::}{/}g;
 192
 193     if ( my $inc_entry = $INC{$file} ) {
 194         {
 195             # look for an uninstalled Catalyst app
 196
 197             # find the @INC entry in which $file was found
 198             (my $path = $inc_entry) =~ s/$file$//;
 199             $path ||= cwd() if !defined $path || !length $path;
 200             my $home = dir($path)->absolute->cleanup;
 201
 202             # pop off /lib and /blib if they're there
 203             $home = $home->parent while $home =~ /b?lib$/;
 204
 205             # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
 206             if (grep { -f $home->file($_) } dist_indicator_file_list()) {
 207                 # clean up relative path:
 208                 # MyApp/script/.. -> MyApp
 209
 210                 my $dir;
 211                 my @dir_list = $home->dir_list();
 212                 while (($dir = pop(@dir_list)) && $dir eq '..') {
 213                     $home = dir($home)->parent->parent;
 214                 }
 215
 216                 return $home->stringify;
 217             }
 218         }
 219
 220         {
 221             # look for an installed Catalyst app
 222
 223             # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
 224             ( my $path = $inc_entry) =~ s/\.pm$//;
 225             my $home = dir($path)->absolute->cleanup;
 226
 227             # return if if it's a valid directory
 228             return $home->stringify if -d $home;
 229         }
 230     }
 231
 232     # we found nothing
 233     return 0;
 234 }
 235
 236 =head2 prefix($class, $name);
 237
 238 Returns a prefixed action.
 239
 240     MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
 241
 242 =cut
 243
 244 sub prefix {
 245     my ( $class, $name ) = @_;
 246     my $prefix = &class2prefix($class);
 247     $name = "$prefix/$name" if $prefix;
 248     return $name;
 249 }
 250
 251 =head2 request($uri)
 252
 253 Returns an L<HTTP::Request> object for a uri.
 254
 255 =cut
 256
 257 sub request {
 258     my $request = shift;
 259     unless ( ref $request ) {
 260         if ( $request =~ m/^http/i ) {
 261             $request = URI->new($request);
 262         }
 263         else {
 264             $request = URI->new( 'http://localhost' . $request );
 265         }
 266     }
 267     unless ( ref $request eq 'HTTP::Request' ) {
 268         $request = HTTP::Request->new( 'GET', $request );
 269     }
 270     return $request;
 271 }
 272
 273 =head2 ensure_class_loaded($class_name, \%opts)
 274
 275 Loads the class unless it already has been loaded.
 276
 277 If $opts{ignore_loaded} is true always tries the require whether the package
 278 already exists or not. Only pass this if you're either (a) sure you know the
 279 file exists on disk or (b) have code to catch the file not found exception
 280 that will result if it doesn't.
 281
 282 =cut
 283
 284 sub ensure_class_loaded {
 285     my $class = shift;
 286     my $opts  = shift;
 287
 288     croak "Malformed class Name $class"
 289         if $class =~ m/(?:\b\:\b|\:{3,})/;
 290
 291     croak "Malformed class Name $class"
 292         if $class =~ m/[^\w:]/;
 293
 294     croak "ensure_class_loaded should be given a classname, not a filename ($class)"
 295         if $class =~ m/\.pm$/;
 296
 297     # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
 298     # if it already has symbol table entries. This is to support things like Schema::Loader, which
 299     # part-generate classes in memory, but then also load some of their contents from disk.
 300     return if !$opts->{ ignore_loaded }
 301         && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
 302
 303     # this hack is so we don't overwrite $@ if the load did not generate an error
 304     my $error;
 305     {
 306         local $@;
 307         my $file = $class . '.pm';
 308         $file =~ s{::}{/}g;
 309         eval { CORE::require($file) };
 310         $error = $@;
 311     }
 312
 313     die $error if $error;
 314
 315     warn "require $class was successful but the package is not defined."
 316         unless Class::MOP::is_class_loaded($class);
 317
 318     return 1;
 319 }
 320
 321 =head2 merge_hashes($hashref, $hashref)
 322
 323 Base code to recursively merge two hashes together with right-hand precedence.
 324
 325 =cut
 326
 327 sub merge_hashes {
 328     my ( $lefthash, $righthash ) = @_;
 329
 330     return $lefthash unless defined $righthash;
 331
 332     my %merged = %$lefthash;
 333     for my $key ( keys %$righthash ) {
 334         my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
 335         my $left_ref  = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
 336         if( $right_ref and $left_ref ) {
 337             $merged{ $key } = merge_hashes(
 338                 $lefthash->{ $key }, $righthash->{ $key }
 339             );
 340         }
 341         else {
 342             $merged{ $key } = $righthash->{ $key };
 343         }
 344     }
 345
 346     return \%merged;
 347 }
 348
 349 =head2 env_value($class, $key)
 350
 351 Checks for and returns an environment value. For instance, if $key is
 352 'home', then this method will check for and return the first value it finds,
 353 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
 354
 355 =cut
 356
 357 sub env_value {
 358     my ( $class, $key ) = @_;
 359
 360     $key = uc($key);
 361     my @prefixes = ( class2env($class), 'CATALYST' );
 362
 363     for my $prefix (@prefixes) {
 364         if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
 365             return $value;
 366         }
 367     }
 368
 369     return;
 370 }
 371
 372 =head2 term_width
 373
 374 Try to guess terminal width to use with formatting of debug output
 375
 376 All you need to get this work, is:
 377
 378 1) Install Term::Size::Any, or
 379
 380 2) Export $COLUMNS from your shell.
 381
 382 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
 383 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
 384 that 'env' now lists COLUMNS.)
 385
 386 As last resort, default value of 80 chars will be used.
 387
 388 =cut
 389
 390 my $_term_width;
 391
 392 sub term_width {
 393     return $_term_width if $_term_width;
 394
 395     my $width = eval '
 396         use Term::Size::Any;
 397         my ($columns, $rows) = Term::Size::Any::chars;
 398         return $columns;
 399     ';
 400
 401     if ($@) {
 402         $width = $ENV{COLUMNS}
 403             if exists($ENV{COLUMNS})
 404             && $ENV{COLUMNS} =~ m/^\d+$/;
 405     }
 406
 407     $width = 80 unless ($width && $width >= 80);
 408     return $_term_width = $width;
 409 }
 410
 411
 412 =head2 resolve_namespace
 413
 414 Method which adds the namespace for plugins and actions.
 415
 416   __PACKAGE__->setup(qw(MyPlugin));
 417
 418   # will load Catalyst::Plugin::MyPlugin
 419
 420 =cut
 421
 422
 423 sub resolve_namespace {
 424     my $appnamespace = shift;
 425     my $namespace = shift;
 426     my @classes = @_;
 427     return String::RewritePrefix->rewrite({
 428         q[]  => qq[${namespace}::],
 429         q[+] => q[],
 430         (defined $appnamespace
 431             ? (q[~] => qq[${appnamespace}::])
 432             : ()
 433         ),
 434     }, @classes);
 435 }
 436
 437 =head2 build_middleware (@args)
 438
 439 Internal application that converts a single middleware definition (see
 440 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
 441
 442 =cut
 443
 444 sub build_middleware {
 445     my ($class, $namespace, @init_args) = @_;
 446
 447     if(
 448       $namespace =~s/^\+// ||
 449       $namespace =~/^Plack::Middleware/ ||
 450       $namespace =~/^$class/
 451     ) {  ## the string is a full namespace
 452         return Class::Load::try_load_class($namespace) ?
 453           $namespace->new(@init_args) :
 454             die "Can't load class $namespace";
 455     } else { ## the string is a partial namespace
 456       if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
 457           my $ns = $class .'::Middleware::'. $namespace;
 458           return $ns->new(@init_args);
 459         } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
 460           return "Plack::Middleware::$namespace"->new(@init_args);
 461         }
 462     }
 463
 464     return; ## be sure we can count on a proper return when valid
 465 }
 466
 467 =head2 apply_registered_middleware ($psgi)
 468
 469 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
 470 around it and return the wrapped version.
 471
 472 This exists to deal with the fact Catalyst registered middleware can be
 473 either an object with a wrap method or a coderef.
 474
 475 =cut
 476
 477 sub apply_registered_middleware {
 478     my ($class, $psgi) = @_;
 479     my $new_psgi = $psgi;
 480     foreach my $middleware ($class->registered_middlewares) {
 481         $new_psgi = Scalar::Util::blessed $middleware ?
 482           $middleware->wrap($new_psgi) :
 483             $middleware->($new_psgi);
 484     }
 485     return $new_psgi;
 486 }
 487
 488 =head1 AUTHORS
 489
 490 Catalyst Contributors, see Catalyst.pm
 491
 492 =head1 COPYRIGHT
 493
 494 This library is free software. You can redistribute it and/or modify it under
 495 the same terms as Perl itself.
 496
 497 =cut
 498
 499 1;