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 (!defined $_use_term_size_any) {
408 require Term::Size::Any;
409 Term::Size::Any->import();
410 $_use_term_size_any = 1;
413 if ( $@ =~ m[Can't locate Term/Size/Any\.pm] ) {
414 warn "Term::Size::Any is not installed, can't autodetect terminal column width\n";
417 warn "There was an error trying to detect your terminal size: $@\n";
419 $_use_term_size_any = 0;
425 if ($_use_term_size_any) {
426 ($width) = Term::Size::Any::chars();
429 if (!$width && $ENV{COLUMNS} && $ENV{COLUMNS} =~ /\A\d+\z/) {
430 $width = $ENV{COLUMNS};
432 if (!$width || $width < 80) {
436 return $_term_width = $width;
440 =head2 resolve_namespace
442 Method which adds the namespace for plugins and actions.
444 __PACKAGE__->setup(qw(MyPlugin));
446 # will load Catalyst::Plugin::MyPlugin
451 sub resolve_namespace {
452 my $appnamespace = shift;
453 my $namespace = shift;
455 return String::RewritePrefix->rewrite({
456 q[] => qq[${namespace}::],
458 (defined $appnamespace
459 ? (q[~] => qq[${appnamespace}::])
465 =head2 build_middleware (@args)
467 Internal application that converts a single middleware definition (see
468 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
472 sub build_middleware {
473 my ($class, $namespace, @init_args) = @_;
476 $namespace =~s/^\+// ||
477 $namespace =~/^Plack::Middleware/ ||
478 $namespace =~/^$class/
479 ) { ## the string is a full namespace
480 return Class::Load::try_load_class($namespace) ?
481 $namespace->new(@init_args) :
482 die "Can't load class $namespace";
483 } else { ## the string is a partial namespace
484 if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
485 my $ns = $class .'::Middleware::'. $namespace;
486 return $ns->new(@init_args);
487 } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
488 return "Plack::Middleware::$namespace"->new(@init_args);
490 die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
494 return; ## be sure we can count on a proper return when valid
497 =head2 apply_registered_middleware ($psgi)
499 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
500 around it and return the wrapped version.
502 This exists to deal with the fact Catalyst registered middleware can be
503 either an object with a wrap method or a coderef.
507 sub apply_registered_middleware {
508 my ($class, $psgi) = @_;
509 my $new_psgi = $psgi;
510 foreach my $middleware ($class->registered_middlewares) {
511 $new_psgi = Scalar::Util::blessed $middleware ?
512 $middleware->wrap($new_psgi) :
513 $middleware->($new_psgi);
518 =head2 inject_component
520 Used to add components at runtime:
522 into The Catalyst package to inject into (e.g. My::App)
523 component The component package to inject
524 traits (Optional) ArrayRef of L<Moose::Role>s that the component should consume.
525 as An optional moniker to use as the package name for the derived component
529 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )
531 The above will create 'My::App::Controller::Other::App::Controller::Apple'
533 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )
535 The above will create 'My::App::Controller::Apple'
537 Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );
539 Will inject Controller, Model, and View components into your Catalyst application
540 at setup (run)time. It does this by creating a new package on-the-fly, having that
541 package extend the given component, and then having Catalyst setup the new component
542 (via $app->setup_component).
544 B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>. If you were using that
545 you can now use this safely instead. Going forward changes required to make this work will be
546 synchronized with the core method.
548 B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature.
550 B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose>
555 sub inject_component {
557 my ($into, $component, $as) = @given{qw/into component as/};
559 croak "No Catalyst (package) given" unless $into;
560 croak "No component (package) given" unless $component;
562 Class::Load::load_class($component);
565 unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) {
567 for (qw/ Controller Model View /) {
568 if ( $component->isa( "Catalyst::$_" ) ) {
573 croak "Don't know what kind of component \"$component\" is" unless $category;
574 $as = "${category}::$as";
576 my $component_package = join '::', $into, $as;
578 unless ( Class::Load::is_class_loaded $component_package ) {
579 eval "package $component_package; use base qw/$component/; 1;" or
580 croak "Unable to build component package for \"$component_package\": $@";
581 Moose::Util::apply_all_roles($component_package, @{$given{traits}}) if $given{traits};
582 (my $file = "$component_package.pm") =~ s{::}{/}g;
586 my $_setup_component = sub {
588 my $component_package = shift;
589 $into->components->{$component_package} = $into->delayed_setup_component( $component_package );
592 $_setup_component->( $into, $component_package );
597 Utility functions to make it easier to work with PSGI applications under Catalyst
599 =head2 env_at_path_prefix
601 Localize C<$env> under the current controller path prefix:
603 package MyApp::Controller::User;
607 use base 'Catalyst::Controller';
611 my $env = $c->Catalyst::Utils::env_at_path_prefix;
614 Assuming you have a request like GET /user/name:
616 In the example case C<$env> will have PATH_INFO of '/name' instead of
617 '/user/name' and SCRIPT_NAME will now be '/user'.
621 sub env_at_path_prefix {
623 my $path_prefix = $ctx->controller->path_prefix;
624 my $env = $ctx->request->env;
625 my $path_info = $env->{PATH_INFO};
626 my $script_name = ($env->{SCRIPT_NAME} || '');
628 $path_info =~ s/(^\/\Q$path_prefix\E)//;
629 $script_name = "$script_name$1";
633 PATH_INFO => $path_info,
634 SCRIPT_NAME => $script_name };
639 Localize C<$env> under the current action namespace.
641 package MyApp::Controller::User;
645 use base 'Catalyst::Controller';
649 my $env = $c->Catalyst::Utils::env_at_action;
652 Assuming you have a request like GET /user/name:
654 In the example case C<$env> will have PATH_INFO of '/' instead of
655 '/user/name' and SCRIPT_NAME will now be '/user/name'.
657 Alternatively, assuming you have a request like GET /user/name/foo:
659 In this example case C<$env> will have PATH_INFO of '/foo' instead of
660 '/user/name/foo' and SCRIPT_NAME will now be '/user/name'.
662 This is probably a common case where you want to mount a PSGI application
663 under an action but let the Args fall through to the PSGI app.
669 my $argpath = join '/', @{$ctx->request->arguments};
670 my $path = '/' . $ctx->request->path;
672 $path =~ s/\/?\Q$argpath\E\/?$//;
674 my $env = $ctx->request->env;
675 my $path_info = $env->{PATH_INFO};
676 my $script_name = ($env->{SCRIPT_NAME} || '');
678 $path_info =~ s/(^\Q$path\E)//;
679 $script_name = "$script_name$1";
683 PATH_INFO => $path_info,
684 SCRIPT_NAME => $script_name };
687 =head2 env_at_request_uri
689 Localize C<$env> under the current request URI:
691 package MyApp::Controller::User;
695 use base 'Catalyst::Controller';
697 sub name :Local Args(1) {
698 my ($self, $c, $id) = @_;
699 my $env = $c->Catalyst::Utils::env_at_request_uri
702 Assuming you have a request like GET /user/name/hello:
704 In the example case C<$env> will have PATH_INFO of '/' instead of
705 '/user/name' and SCRIPT_NAME will now be '/user/name/hello'.
709 sub env_at_request_uri {
711 my $path = '/' . $ctx->request->path;
712 my $env = $ctx->request->env;
713 my $path_info = $env->{PATH_INFO};
714 my $script_name = ($env->{SCRIPT_NAME} || '');
716 $path_info =~ s/(^\Q$path\E)//;
717 $script_name = "$script_name$1";
721 PATH_INFO => $path_info,
722 SCRIPT_NAME => $script_name };
727 Catalyst Contributors, see Catalyst.pm
731 This library is free software. You can redistribute it and/or modify it under
732 the same terms as Perl itself.