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