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