1 package Catalyst::Utils;
10 use Class::Load 'is_class_loaded';
11 use String::RewritePrefix;
14 use Devel::InnerPackage;
19 Catalyst::Utils - The Catalyst Utils
31 =head2 appprefix($class)
33 MyApp::Foo becomes myapp_foo
44 =head2 class2appclass($class);
46 MyApp::Controller::Foo::Bar becomes MyApp
47 My::App::Controller::Foo::Bar becomes My::App
52 my $class = shift || '';
54 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
60 =head2 class2classprefix($class);
62 MyApp::Controller::Foo::Bar becomes MyApp::Controller
63 My::App::Controller::Foo::Bar becomes My::App::Controller
67 sub class2classprefix {
68 my $class = shift || '';
70 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
76 =head2 class2classsuffix($class);
78 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
82 sub class2classsuffix {
83 my $class = shift || '';
84 my $prefix = class2appclass($class) || '';
85 $class =~ s/$prefix\:://;
89 =head2 class2env($class);
91 Returns the environment name for class.
94 My::App becomes MY_APP
99 my $class = shift || '';
104 =head2 class2prefix( $class, $case );
106 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
108 My::App::Controller::Foo::Bar becomes foo/bar
113 my $class = shift || '';
114 my $case = shift || 0;
116 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
117 $prefix = $case ? $2 : lc $2;
118 $prefix =~ s{::}{/}g;
123 =head2 class2tempdir( $class [, $create ] );
125 Returns a tempdir for a class. If create is true it will try to create the path.
127 My::App becomes /tmp/my/app
128 My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
133 my $class = shift || '';
134 my $create = shift || 0;
135 my @parts = split '::', lc $class;
137 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
139 if ( $create && !-e $tmpdir ) {
141 eval { $tmpdir->mkpath; 1 }
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
147 # $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
149 require Catalyst::Exception;
150 Catalyst::Exception->throw(
151 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
155 return $tmpdir->stringify;
160 Returns home directory for given class.
162 =head2 dist_indicator_file_list
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.
183 sub dist_indicator_file_list {
184 qw{Makefile.PL Build.PL dist.ini cpanfile};
190 # make an $INC{ $key } style string from the class name
191 (my $file = "$class.pm") =~ s{::}{/}g;
193 if ( my $inc_entry = $INC{$file} ) {
195 # look for an uninstalled Catalyst app
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;
202 # pop off /lib and /blib if they're there
203 $home = $home->parent while $home =~ /b?lib$/;
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
211 my @dir_list = $home->dir_list();
212 while (($dir = pop(@dir_list)) && $dir eq '..') {
213 $home = dir($home)->parent->parent;
216 return $home->stringify;
221 # look for an installed Catalyst app
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;
227 # return if it's a valid directory
228 return $home->stringify if -d $home;
236 =head2 prefix($class, $name);
238 Returns a prefixed action.
240 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
245 my ( $class, $name ) = @_;
246 my $prefix = &class2prefix($class);
247 $name = "$prefix/$name" if $prefix;
253 Returns an L<HTTP::Request> object for a uri.
259 unless ( ref $request ) {
260 if ( $request =~ m/^http/i ) {
261 $request = URI->new($request);
264 $request = URI->new( 'http://localhost' . $request );
267 unless ( ref $request eq 'HTTP::Request' ) {
268 $request = HTTP::Request->new( 'GET', $request );
273 =head2 ensure_class_loaded($class_name, \%opts)
275 Loads the class unless it already has been loaded.
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.
284 sub ensure_class_loaded {
288 croak "Malformed class Name $class"
289 if $class =~ m/(?:\b\:\b|\:{3,})/;
291 croak "Malformed class Name $class"
292 if $class =~ m/[^\w:]/;
294 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
295 if $class =~ m/\.pm$/;
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
303 # this hack is so we don't overwrite $@ if the load did not generate an error
307 my $file = $class . '.pm';
309 eval { CORE::require($file) };
313 die $error if $error;
315 warn "require $class was successful but the package is not defined."
316 unless is_class_loaded($class);
321 =head2 merge_hashes($hashref, $hashref)
323 Base code to recursively merge two hashes together with right-hand precedence.
328 my ( $lefthash, $righthash ) = @_;
330 return $lefthash unless defined $righthash;
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 }
342 $merged{ $key } = $righthash->{ $key };
349 =head2 env_value($class, $key)
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}.
358 my ( $class, $key ) = @_;
361 my @prefixes = ( class2env($class), 'CATALYST' );
363 for my $prefix (@prefixes) {
364 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
374 Try to guess terminal width to use with formatting of debug output
376 All you need to get this work, is:
378 1) Install Term::Size::Any, or
380 2) Export $COLUMNS from your shell.
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.)
386 As last resort, default value of 80 chars will be used.
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
392 $SIG{WINCH} = sub { Catalyst::Utils::term_width(1) };
397 my $_use_term_size_any;
400 my $force_reset = shift;
402 undef $_term_width if $force_reset;
404 return $_term_width if $_term_width;
406 if ($ENV{COLUMNS} && $ENV{COLUMNS} =~ /\A\d+\z/) {
407 return $_term_width = $ENV{COLUMNS};
410 if (!-t STDOUT && !-t STDERR) {
411 return $_term_width = 80;
414 if (!defined $_use_term_size_any) {
416 require Term::Size::Any;
417 Term::Size::Any->import();
418 $_use_term_size_any = 1;
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";
425 warn "There was an error trying to detect your terminal size: $@\n";
427 $_use_term_size_any = 0;
433 if ($_use_term_size_any) {
434 $width = Term::Size::Any::chars(*STDERR) || Term::Size::Any::chars(*STDOUT);
437 if (!$width || $width < 80) {
441 return $_term_width = $width;
445 =head2 resolve_namespace
447 Method which adds the namespace for plugins and actions.
449 __PACKAGE__->setup(qw(MyPlugin));
451 # will load Catalyst::Plugin::MyPlugin
456 sub resolve_namespace {
457 my $appnamespace = shift;
458 my $namespace = shift;
460 return String::RewritePrefix->rewrite({
461 q[] => qq[${namespace}::],
463 (defined $appnamespace
464 ? (q[~] => qq[${appnamespace}::])
470 =head2 build_middleware (@args)
472 Internal application that converts a single middleware definition (see
473 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
477 sub build_middleware {
478 my ($class, $namespace, @init_args) = @_;
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);
495 die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
499 return; ## be sure we can count on a proper return when valid
502 =head2 apply_registered_middleware ($psgi)
504 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
505 around it and return the wrapped version.
507 This exists to deal with the fact Catalyst registered middleware can be
508 either an object with a wrap method or a coderef.
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);
523 =head2 inject_component
525 Used to add components at runtime:
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
534 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )
536 The above will create 'My::App::Controller::Other::App::Controller::Apple'
538 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )
540 The above will create 'My::App::Controller::Apple'
542 Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );
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).
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.
553 B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature.
555 B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose>
560 sub inject_component {
562 my ($into, $component, $as) = @given{qw/into component as/};
564 croak "No Catalyst (package) given" unless $into;
565 croak "No component (package) given" unless $component;
567 Class::Load::load_class($component);
570 unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) {
572 for (qw/ Controller Model View /) {
573 if ( $component->isa( "Catalyst::$_" ) ) {
578 croak "Don't know what kind of component \"$component\" is" unless $category;
579 $as = "${category}::$as";
581 my $component_package = join '::', $into, $as;
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;
591 my $_setup_component = sub {
593 my $component_package = shift;
594 $into->components->{$component_package} = $into->delayed_setup_component( $component_package );
597 $_setup_component->( $into, $component_package );
602 Utility functions to make it easier to work with PSGI applications under Catalyst
604 =head2 env_at_path_prefix
606 Localize C<$env> under the current controller path prefix:
608 package MyApp::Controller::User;
612 use base 'Catalyst::Controller';
616 my $env = $c->Catalyst::Utils::env_at_path_prefix;
619 Assuming you have a request like GET /user/name:
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'.
626 sub env_at_path_prefix {
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} || '');
633 $path_info =~ s/(^\/\Q$path_prefix\E)//;
634 $script_name = "$script_name$1";
638 PATH_INFO => $path_info,
639 SCRIPT_NAME => $script_name };
644 Localize C<$env> under the current action namespace.
646 package MyApp::Controller::User;
650 use base 'Catalyst::Controller';
654 my $env = $c->Catalyst::Utils::env_at_action;
657 Assuming you have a request like GET /user/name:
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'.
662 Alternatively, assuming you have a request like GET /user/name/foo:
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'.
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.
674 my $argpath = join '/', @{$ctx->request->arguments};
675 my $path = '/' . $ctx->request->path;
677 $path =~ s/\/?\Q$argpath\E\/?$//;
679 my $env = $ctx->request->env;
680 my $path_info = $env->{PATH_INFO};
681 my $script_name = ($env->{SCRIPT_NAME} || '');
683 $path_info =~ s/(^\Q$path\E)//;
684 $script_name = "$script_name$1";
688 PATH_INFO => $path_info,
689 SCRIPT_NAME => $script_name };
692 =head2 env_at_request_uri
694 Localize C<$env> under the current request URI:
696 package MyApp::Controller::User;
700 use base 'Catalyst::Controller';
702 sub name :Local Args(1) {
703 my ($self, $c, $id) = @_;
704 my $env = $c->Catalyst::Utils::env_at_request_uri
707 Assuming you have a request like GET /user/name/hello:
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'.
714 sub env_at_request_uri {
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} || '');
721 $path_info =~ s/(^\Q$path\E)//;
722 $script_name = "$script_name$1";
726 PATH_INFO => $path_info,
727 SCRIPT_NAME => $script_name };
732 Catalyst Contributors, see Catalyst.pm
736 This library is free software. You can redistribute it and/or modify it under
737 the same terms as Perl itself.