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) };
399 my $force_reset = shift;
401 undef $_term_width if $force_reset;
403 return $_term_width if $_term_width;
408 ($width) = Term::Size::Any::chars;
411 if($@ =~m[Can't locate Term/Size/Any.pm]) {
412 warn "Term::Size::Any is not installed, can't autodetect terminal column width\n";
414 warn "There was an error trying to detect your terminal size: $@\n";
419 warn 'Trouble trying to detect your terminal size, looking at $ENV{COLUMNS}'."\n";
420 $width = $ENV{COLUMNS}
421 if exists($ENV{COLUMNS})
422 && $ENV{COLUMNS} =~ m/^\d+$/;
426 warn "Cannot determine desired terminal width, using default of 80 columns\n";
427 $width = 80 } unless ($width && $width >= 80);
428 return $_term_width = $width;
432 =head2 resolve_namespace
434 Method which adds the namespace for plugins and actions.
436 __PACKAGE__->setup(qw(MyPlugin));
438 # will load Catalyst::Plugin::MyPlugin
443 sub resolve_namespace {
444 my $appnamespace = shift;
445 my $namespace = shift;
447 return String::RewritePrefix->rewrite({
448 q[] => qq[${namespace}::],
450 (defined $appnamespace
451 ? (q[~] => qq[${appnamespace}::])
457 =head2 build_middleware (@args)
459 Internal application that converts a single middleware definition (see
460 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
464 sub build_middleware {
465 my ($class, $namespace, @init_args) = @_;
468 $namespace =~s/^\+// ||
469 $namespace =~/^Plack::Middleware/ ||
470 $namespace =~/^$class/
471 ) { ## the string is a full namespace
472 return Class::Load::try_load_class($namespace) ?
473 $namespace->new(@init_args) :
474 die "Can't load class $namespace";
475 } else { ## the string is a partial namespace
476 if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
477 my $ns = $class .'::Middleware::'. $namespace;
478 return $ns->new(@init_args);
479 } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
480 return "Plack::Middleware::$namespace"->new(@init_args);
482 die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
486 return; ## be sure we can count on a proper return when valid
489 =head2 apply_registered_middleware ($psgi)
491 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
492 around it and return the wrapped version.
494 This exists to deal with the fact Catalyst registered middleware can be
495 either an object with a wrap method or a coderef.
499 sub apply_registered_middleware {
500 my ($class, $psgi) = @_;
501 my $new_psgi = $psgi;
502 foreach my $middleware ($class->registered_middlewares) {
503 $new_psgi = Scalar::Util::blessed $middleware ?
504 $middleware->wrap($new_psgi) :
505 $middleware->($new_psgi);
510 =head2 inject_component
512 Used to add components at runtime:
514 into The Catalyst package to inject into (e.g. My::App)
515 component The component package to inject
516 traits (Optional) ArrayRef of L<Moose::Role>s that the componet should consume.
517 as An optional moniker to use as the package name for the derived component
521 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )
523 The above will create 'My::App::Controller::Other::App::Controller::Apple'
525 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )
527 The above will create 'My::App::Controller::Apple'
529 Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );
531 Will inject Controller, Model, and View components into your Catalyst application
532 at setup (run)time. It does this by creating a new package on-the-fly, having that
533 package extend the given component, and then having Catalyst setup the new component
534 (via $app->setup_component).
536 B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>. If you were using that
537 you can now use this safely instead. Going forward changes required to make this work will be
538 synchronized with the core method.
540 B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature.
542 B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose>
547 sub inject_component {
549 my ($into, $component, $as) = @given{qw/into component as/};
551 croak "No Catalyst (package) given" unless $into;
552 croak "No component (package) given" unless $component;
554 Class::Load::load_class($component);
557 unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) {
559 for (qw/ Controller Model View /) {
560 if ( $component->isa( "Catalyst::$_" ) ) {
565 croak "Don't know what kind of component \"$component\" is" unless $category;
566 $as = "${category}::$as";
568 my $component_package = join '::', $into, $as;
570 unless ( Class::Load::is_class_loaded $component_package ) {
571 eval "package $component_package; use base qw/$component/; 1;" or
572 croak "Unable to build component package for \"$component_package\": $@";
573 Moose::Util::apply_all_roles($component_package, @{$given{traits}}) if $given{traits};
574 (my $file = "$component_package.pm") =~ s{::}{/}g;
578 my $_setup_component = sub {
580 my $component_package = shift;
581 $into->components->{$component_package} = $into->delayed_setup_component( $component_package );
584 $_setup_component->( $into, $component_package );
589 Utility functions to make it easier to work with PSGI applications under Catalyst
591 =head2 env_at_path_prefix
593 Localize C<$env> under the current controller path prefix:
595 package MyApp::Controller::User;
599 use base 'Catalyst::Controller';
603 my $env = $c->Catalyst::Utils::env_at_path_prefix;
606 Assuming you have a request like GET /user/name:
608 In the example case C<$env> will have PATH_INFO of '/name' instead of
609 '/user/name' and SCRIPT_NAME will now be '/user'.
613 sub env_at_path_prefix {
615 my $path_prefix = $ctx->controller->path_prefix;
616 my $env = $ctx->request->env;
617 my $path_info = $env->{PATH_INFO};
618 my $script_name = ($env->{SCRIPT_NAME} || '');
620 $path_info =~ s/(^\/\Q$path_prefix\E)//;
621 $script_name = "$script_name$1";
625 PATH_INFO => $path_info,
626 SCRIPT_NAME => $script_name };
631 Localize C<$env> under the current action namespace.
633 package MyApp::Controller::User;
637 use base 'Catalyst::Controller';
641 my $env = $c->Catalyst::Utils::env_at_action;
644 Assuming you have a request like GET /user/name:
646 In the example case C<$env> will have PATH_INFO of '/' instead of
647 '/user/name' and SCRIPT_NAME will now be '/user/name'.
649 Alternatively, assuming you have a request like GET /user/name/foo:
651 In this example case C<$env> will have PATH_INFO of '/foo' instead of
652 '/user/name/foo' and SCRIPT_NAME will now be '/user/name'.
654 This is probably a common case where you want to mount a PSGI application
655 under an action but let the Args fall through to the PSGI app.
661 my $argpath = join '/', @{$ctx->request->arguments};
662 my $path = '/' . $ctx->request->path;
664 $path =~ s/\/?\Q$argpath\E\/?$//;
666 my $env = $ctx->request->env;
667 my $path_info = $env->{PATH_INFO};
668 my $script_name = ($env->{SCRIPT_NAME} || '');
670 $path_info =~ s/(^\Q$path\E)//;
671 $script_name = "$script_name$1";
675 PATH_INFO => $path_info,
676 SCRIPT_NAME => $script_name };
679 =head2 env_at_request_uri
681 Localize C<$env> under the current request URI:
683 package MyApp::Controller::User;
687 use base 'Catalyst::Controller';
689 sub name :Local Args(1) {
690 my ($self, $c, $id) = @_;
691 my $env = $c->Catalyst::Utils::env_at_request_uri
694 Assuming you have a request like GET /user/name/hello:
696 In the example case C<$env> will have PATH_INFO of '/' instead of
697 '/user/name' and SCRIPT_NAME will now be '/user/name/hello'.
701 sub env_at_request_uri {
703 my $path = '/' . $ctx->request->path;
704 my $env = $ctx->request->env;
705 my $path_info = $env->{PATH_INFO};
706 my $script_name = ($env->{SCRIPT_NAME} || '');
708 $path_info =~ s/(^\Q$path\E)//;
709 $script_name = "$script_name$1";
713 PATH_INFO => $path_info,
714 SCRIPT_NAME => $script_name };
719 Catalyst Contributors, see Catalyst.pm
723 This library is free software. You can redistribute it and/or modify it under
724 the same terms as Perl itself.