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 use Devel::InnerPackage;
  15 use Moose::Util;
  16
  17 =head1 NAME
  18
  19 Catalyst::Utils - The Catalyst Utils
  20
  21 =head1 SYNOPSIS
  22
  23 See L<Catalyst>.
  24
  25 =head1 DESCRIPTION
  26
  27 Catalyst Utilities.
  28
  29 =head1 METHODS
  30
  31 =head2 appprefix($class)
  32
  33     MyApp::Foo becomes myapp_foo
  34
  35 =cut
  36
  37 sub appprefix {
  38     my $class = shift;
  39     $class =~ s/::/_/g;
  40     $class = lc($class);
  41     return $class;
  42 }
  43
  44 =head2 class2appclass($class);
  45
  46     MyApp::Controller::Foo::Bar becomes MyApp
  47     My::App::Controller::Foo::Bar becomes My::App
  48
  49 =cut
  50
  51 sub class2appclass {
  52     my $class = shift || '';
  53     my $appname = '';
  54     if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
  55         $appname = $1;
  56     }
  57     return $appname;
  58 }
  59
  60 =head2 class2classprefix($class);
  61
  62     MyApp::Controller::Foo::Bar becomes MyApp::Controller
  63     My::App::Controller::Foo::Bar becomes My::App::Controller
  64
  65 =cut
  66
  67 sub class2classprefix {
  68     my $class = shift || '';
  69     my $prefix;
  70     if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
  71         $prefix = $1;
  72     }
  73     return $prefix;
  74 }
  75
  76 =head2 class2classsuffix($class);
  77
  78     MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
  79
  80 =cut
  81
  82 sub class2classsuffix {
  83     my $class = shift || '';
  84     my $prefix = class2appclass($class) || '';
  85     $class =~ s/$prefix\:://;
  86     return $class;
  87 }
  88
  89 =head2 class2env($class);
  90
  91 Returns the environment name for class.
  92
  93     MyApp becomes MYAPP
  94     My::App becomes MY_APP
  95
  96 =cut
  97
  98 sub class2env {
  99     my $class = shift || '';
 100     $class =~ s/::/_/g;
 101     return uc($class);
 102 }
 103
 104 =head2 class2prefix( $class, $case );
 105
 106 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
 107
 108     My::App::Controller::Foo::Bar becomes foo/bar
 109
 110 =cut
 111
 112 sub class2prefix {
 113     my $class = shift || '';
 114     my $case  = shift || 0;
 115     my $prefix;
 116     if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
 117         $prefix = $case ? $2 : lc $2;
 118         $prefix =~ s{::}{/}g;
 119     }
 120     return $prefix;
 121 }
 122
 123 =head2 class2tempdir( $class [, $create ] );
 124
 125 Returns a tempdir for a class. If create is true it will try to create the path.
 126
 127     My::App becomes /tmp/my/app
 128     My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
 129
 130 =cut
 131
 132 sub class2tempdir {
 133     my $class  = shift || '';
 134     my $create = shift || 0;
 135     my @parts = split '::', lc $class;
 136
 137     my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
 138
 139     if ( $create && !-e $tmpdir ) {
 140
 141         eval { $tmpdir->mkpath; 1 }
 142         or do {
 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 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         && 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 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 Calling C<term_width> with a true value will cause it to be recalculated; you
 389 can use this to cause it to get recalculated when your terminal is resized like
 390 this
 391
 392  $SIG{WINCH} = sub { Catalyst::Utils::term_width(1) };
 393
 394 =cut
 395
 396 my $_term_width;
 397 my $_use_term_size_any;
 398
 399 sub term_width {
 400     my $force_reset = shift;
 401
 402     undef $_term_width if $force_reset;
 403
 404     return $_term_width if $_term_width;
 405
 406     if ($ENV{COLUMNS} && $ENV{COLUMNS} =~ /\A\d+\z/) {
 407         return $_term_width = $ENV{COLUMNS};
 408     }
 409
 410     if (!-t STDOUT && !-t STDERR) {
 411         return $_term_width = 80;
 412     }
 413
 414     if (!defined $_use_term_size_any) {
 415         eval {
 416             require Term::Size::Any;
 417             Term::Size::Any->import();
 418             $_use_term_size_any = 1;
 419             1;
 420         } or do {
 421             if ( $@ =~ m[Can't locate Term/Size/Any\.pm] ) {
 422                 warn "Term::Size::Any is not installed, can't autodetect terminal column width\n";
 423             }
 424             else {
 425                 warn "There was an error trying to detect your terminal size: $@\n";
 426             }
 427             $_use_term_size_any = 0;
 428         };
 429     }
 430
 431     my $width;
 432
 433     if ($_use_term_size_any) {
 434         $width = Term::Size::Any::chars(*STDERR) || Term::Size::Any::chars(*STDOUT);
 435     }
 436
 437     if (!$width || $width < 80) {
 438         $width = 80;
 439     }
 440
 441     return $_term_width = $width;
 442 }
 443
 444
 445 =head2 resolve_namespace
 446
 447 Method which adds the namespace for plugins and actions.
 448
 449   __PACKAGE__->setup(qw(MyPlugin));
 450
 451   # will load Catalyst::Plugin::MyPlugin
 452
 453 =cut
 454
 455
 456 sub resolve_namespace {
 457     my $appnamespace = shift;
 458     my $namespace = shift;
 459     my @classes = @_;
 460     return String::RewritePrefix->rewrite({
 461         q[]  => qq[${namespace}::],
 462         q[+] => q[],
 463         (defined $appnamespace
 464             ? (q[~] => qq[${appnamespace}::])
 465             : ()
 466         ),
 467     }, @classes);
 468 }
 469
 470 =head2 build_middleware (@args)
 471
 472 Internal application that converts a single middleware definition (see
 473 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
 474
 475 =cut
 476
 477 sub build_middleware {
 478     my ($class, $namespace, @init_args) = @_;
 479
 480     if(
 481       $namespace =~s/^\+// ||
 482       $namespace =~/^Plack::Middleware/ ||
 483       $namespace =~/^$class/
 484     ) {  ## the string is a full namespace
 485         return Class::Load::try_load_class($namespace) ?
 486           $namespace->new(@init_args) :
 487             die "Can't load class $namespace";
 488     } else { ## the string is a partial namespace
 489       if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
 490           my $ns = $class .'::Middleware::'. $namespace;
 491           return $ns->new(@init_args);
 492         } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
 493           return "Plack::Middleware::$namespace"->new(@init_args);
 494         } else {
 495           die "Can't load middleware via '$namespace'.  It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
 496         }
 497     }
 498
 499     return; ## be sure we can count on a proper return when valid
 500 }
 501
 502 =head2 apply_registered_middleware ($psgi)
 503
 504 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
 505 around it and return the wrapped version.
 506
 507 This exists to deal with the fact Catalyst registered middleware can be
 508 either an object with a wrap method or a coderef.
 509
 510 =cut
 511
 512 sub apply_registered_middleware {
 513     my ($class, $psgi) = @_;
 514     my $new_psgi = $psgi;
 515     foreach my $middleware ($class->registered_middlewares) {
 516         $new_psgi = Scalar::Util::blessed $middleware ?
 517           $middleware->wrap($new_psgi) :
 518             $middleware->($new_psgi);
 519     }
 520     return $new_psgi;
 521 }
 522
 523 =head2 inject_component
 524
 525 Used to add components at runtime:
 526
 527     into        The Catalyst package to inject into (e.g. My::App)
 528     component   The component package to inject
 529     traits      (Optional) ArrayRef of L<Moose::Role>s that the component should consume.
 530     as          An optional moniker to use as the package name for the derived component
 531
 532 For example:
 533
 534     Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )
 535
 536         The above will create 'My::App::Controller::Other::App::Controller::Apple'
 537
 538     Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )
 539
 540         The above will create 'My::App::Controller::Apple'
 541
 542     Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );
 543
 544 Will inject Controller, Model, and View components into your Catalyst application
 545 at setup (run)time. It does this by creating a new package on-the-fly, having that
 546 package extend the given component, and then having Catalyst setup the new component
 547 (via $app->setup_component).
 548
 549 B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>.  If you were using that
 550 you can now use this safely instead.  Going forward changes required to make this work will be
 551 synchronized with the core method.
 552
 553 B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature.
 554
 555 B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose>
 556 based class.
 557
 558 =cut
 559
 560 sub inject_component {
 561     my %given = @_;
 562     my ($into, $component, $as) = @given{qw/into component as/};
 563
 564     croak "No Catalyst (package) given" unless $into;
 565     croak "No component (package) given" unless $component;
 566
 567     Class::Load::load_class($component);
 568
 569     $as ||= $component;
 570     unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) {
 571         my $category;
 572         for (qw/ Controller Model View /) {
 573             if ( $component->isa( "Catalyst::$_" ) ) {
 574                 $category = $_;
 575                 last;
 576             }
 577         }
 578         croak "Don't know what kind of component \"$component\" is" unless $category;
 579         $as = "${category}::$as";
 580     }
 581     my $component_package = join '::', $into, $as;
 582
 583     unless ( Class::Load::is_class_loaded $component_package ) {
 584         eval "package $component_package; use base qw/$component/; 1;" or
 585             croak "Unable to build component package for \"$component_package\": $@";
 586         Moose::Util::apply_all_roles($component_package, @{$given{traits}}) if $given{traits};
 587         (my $file = "$component_package.pm") =~ s{::}{/}g;
 588         $INC{$file} ||= 1;
 589     }
 590
 591     my $_setup_component = sub {
 592       my $into = shift;
 593       my $component_package = shift;
 594       $into->components->{$component_package} = $into->delayed_setup_component( $component_package );
 595     };
 596
 597     $_setup_component->( $into, $component_package );
 598 }
 599
 600 =head1 PSGI Helpers
 601
 602 Utility functions to make it easier to work with PSGI applications under Catalyst
 603
 604 =head2 env_at_path_prefix
 605
 606 Localize C<$env> under the current controller path prefix:
 607
 608     package MyApp::Controller::User;
 609
 610     use Catalyst::Utils;
 611
 612     use base 'Catalyst::Controller';
 613
 614     sub name :Local {
 615       my ($self, $c) = @_;
 616       my $env = $c->Catalyst::Utils::env_at_path_prefix;
 617     }
 618
 619 Assuming you have a request like GET /user/name:
 620
 621 In the example case C<$env> will have PATH_INFO of '/name' instead of
 622 '/user/name' and SCRIPT_NAME will now be '/user'.
 623
 624 =cut
 625
 626 sub env_at_path_prefix {
 627   my $ctx = shift;
 628   my $path_prefix = $ctx->controller->path_prefix;
 629   my $env = $ctx->request->env;
 630   my $path_info = $env->{PATH_INFO};
 631   my $script_name = ($env->{SCRIPT_NAME} || '');
 632
 633   $path_info =~ s/(^\/\Q$path_prefix\E)//;
 634   $script_name = "$script_name$1";
 635
 636   return +{
 637     %$env,
 638     PATH_INFO => $path_info,
 639     SCRIPT_NAME => $script_name };
 640 }
 641
 642 =head2 env_at_action
 643
 644 Localize C<$env> under the current action namespace.
 645
 646     package MyApp::Controller::User;
 647
 648     use Catalyst::Utils;
 649
 650     use base 'Catalyst::Controller';
 651
 652     sub name :Local {
 653       my ($self, $c) = @_;
 654       my $env = $c->Catalyst::Utils::env_at_action;
 655     }
 656
 657 Assuming you have a request like GET /user/name:
 658
 659 In the example case C<$env> will have PATH_INFO of '/' instead of
 660 '/user/name' and SCRIPT_NAME will now be '/user/name'.
 661
 662 Alternatively, assuming you have a request like GET /user/name/foo:
 663
 664 In this example case C<$env> will have PATH_INFO of '/foo' instead of
 665 '/user/name/foo' and SCRIPT_NAME will now be '/user/name'.
 666
 667 This is probably a common case where you want to mount a PSGI application
 668 under an action but let the Args fall through to the PSGI app.
 669
 670 =cut
 671
 672 sub env_at_action {
 673   my $ctx = shift;
 674   my $argpath = join '/', @{$ctx->request->arguments};
 675   my $path = '/' . $ctx->request->path;
 676
 677   $path =~ s/\/?\Q$argpath\E\/?$//;
 678
 679   my $env = $ctx->request->env;
 680   my $path_info = $env->{PATH_INFO};
 681   my $script_name = ($env->{SCRIPT_NAME} || '');
 682
 683   $path_info =~ s/(^\Q$path\E)//;
 684   $script_name = "$script_name$1";
 685
 686   return +{
 687     %$env,
 688     PATH_INFO => $path_info,
 689     SCRIPT_NAME => $script_name };
 690 }
 691
 692 =head2 env_at_request_uri
 693
 694 Localize C<$env> under the current request URI:
 695
 696     package MyApp::Controller::User;
 697
 698     use Catalyst::Utils;
 699
 700     use base 'Catalyst::Controller';
 701
 702     sub name :Local Args(1) {
 703       my ($self, $c, $id) = @_;
 704       my $env = $c->Catalyst::Utils::env_at_request_uri
 705     }
 706
 707 Assuming you have a request like GET /user/name/hello:
 708
 709 In the example case C<$env> will have PATH_INFO of '/' instead of
 710 '/user/name' and SCRIPT_NAME will now be '/user/name/hello'.
 711
 712 =cut
 713
 714 sub env_at_request_uri {
 715   my $ctx = shift;
 716   my $path = '/' . $ctx->request->path;
 717   my $env = $ctx->request->env;
 718   my $path_info = $env->{PATH_INFO};
 719   my $script_name = ($env->{SCRIPT_NAME} || '');
 720
 721   $path_info =~ s/(^\Q$path\E)//;
 722   $script_name = "$script_name$1";
 723
 724   return +{
 725     %$env,
 726     PATH_INFO => $path_info,
 727     SCRIPT_NAME => $script_name };
 728 }
 729
 730 =head1 AUTHORS
 731
 732 Catalyst Contributors, see Catalyst.pm
 733
 734 =head1 COPYRIGHT
 735
 736 This library is free software. You can redistribute it and/or modify it under
 737 the same terms as Perl itself.
 738
 739 =cut
 740
 741 1;