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