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";
416 warn 'Trouble trying to detect your terminal size, looking at $ENV{COLUMNS}'."\n";
417 $width = $ENV{COLUMNS}
418 if exists($ENV{COLUMNS})
419 && $ENV{COLUMNS} =~ m/^\d+$/;
423 warn "Cannot determine desired terminal width, using default of 80 columns\n";
424 $width = 80 } unless ($width && $width >= 80);
425 return $_term_width = $width;
429 =head2 resolve_namespace
431 Method which adds the namespace for plugins and actions.
433 __PACKAGE__->setup(qw(MyPlugin));
435 # will load Catalyst::Plugin::MyPlugin
440 sub resolve_namespace {
441 my $appnamespace = shift;
442 my $namespace = shift;
444 return String::RewritePrefix->rewrite({
445 q[] => qq[${namespace}::],
447 (defined $appnamespace
448 ? (q[~] => qq[${appnamespace}::])
454 =head2 build_middleware (@args)
456 Internal application that converts a single middleware definition (see
457 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
461 sub build_middleware {
462 my ($class, $namespace, @init_args) = @_;
465 $namespace =~s/^\+// ||
466 $namespace =~/^Plack::Middleware/ ||
467 $namespace =~/^$class/
468 ) { ## the string is a full namespace
469 return Class::Load::try_load_class($namespace) ?
470 $namespace->new(@init_args) :
471 die "Can't load class $namespace";
472 } else { ## the string is a partial namespace
473 if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
474 my $ns = $class .'::Middleware::'. $namespace;
475 return $ns->new(@init_args);
476 } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
477 return "Plack::Middleware::$namespace"->new(@init_args);
479 die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
483 return; ## be sure we can count on a proper return when valid
486 =head2 apply_registered_middleware ($psgi)
488 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
489 around it and return the wrapped version.
491 This exists to deal with the fact Catalyst registered middleware can be
492 either an object with a wrap method or a coderef.
496 sub apply_registered_middleware {
497 my ($class, $psgi) = @_;
498 my $new_psgi = $psgi;
499 foreach my $middleware ($class->registered_middlewares) {
500 $new_psgi = Scalar::Util::blessed $middleware ?
501 $middleware->wrap($new_psgi) :
502 $middleware->($new_psgi);
507 =head2 inject_component
509 Used to add components at runtime:
511 into The Catalyst package to inject into (e.g. My::App)
512 component The component package to inject
513 traits (Optional) ArrayRef of L<Moose::Role>s that the componet should consume.
514 as An optional moniker to use as the package name for the derived component
518 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )
520 The above will create 'My::App::Controller::Other::App::Controller::Apple'
522 Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )
524 The above will create 'My::App::Controller::Apple'
526 Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );
528 Will inject Controller, Model, and View components into your Catalyst application
529 at setup (run)time. It does this by creating a new package on-the-fly, having that
530 package extend the given component, and then having Catalyst setup the new component
531 (via $app->setup_component).
533 B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>. If you were using that
534 you can now use this safely instead. Going forward changes required to make this work will be
535 synchronized with the core method.
537 B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature.
539 B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose>
544 sub inject_component {
546 my ($into, $component, $as) = @given{qw/into component as/};
548 croak "No Catalyst (package) given" unless $into;
549 croak "No component (package) given" unless $component;
551 Class::Load::load_class($component);
554 unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) {
556 for (qw/ Controller Model View /) {
557 if ( $component->isa( "Catalyst::$_" ) ) {
562 croak "Don't know what kind of component \"$component\" is" unless $category;
563 $as = "${category}::$as";
565 my $component_package = join '::', $into, $as;
567 unless ( Class::Load::is_class_loaded $component_package ) {
568 eval "package $component_package; use base qw/$component/; 1;" or
569 croak "Unable to build component package for \"$component_package\": $@";
570 Moose::Util::apply_all_roles($component_package, @{$given{traits}}) if $given{traits};
571 (my $file = "$component_package.pm") =~ s{::}{/}g;
575 my $_setup_component = sub {
577 my $component_package = shift;
578 $into->components->{$component_package} = $into->delayed_setup_component( $component_package );
581 $_setup_component->( $into, $component_package );
586 Utility functions to make it easier to work with PSGI applications under Catalyst
588 =head2 env_at_path_prefix
590 Localize C<$env> under the current controller path prefix:
592 package MyApp::Controller::User;
596 use base 'Catalyst::Controller';
600 my $env = $c->Catalyst::Utils::env_at_path_prefix;
603 Assuming you have a request like GET /user/name:
605 In the example case C<$env> will have PATH_INFO of '/name' instead of
606 '/user/name' and SCRIPT_NAME will now be '/user'.
610 sub env_at_path_prefix {
612 my $path_prefix = $ctx->controller->path_prefix;
613 my $env = $ctx->request->env;
614 my $path_info = $env->{PATH_INFO};
615 my $script_name = ($env->{SCRIPT_NAME} || '');
617 $path_info =~ s/(^\/\Q$path_prefix\E)//;
618 $script_name = "$script_name$1";
622 PATH_INFO => $path_info,
623 SCRIPT_NAME => $script_name };
628 Localize C<$env> under the current action namespace.
630 package MyApp::Controller::User;
634 use base 'Catalyst::Controller';
638 my $env = $c->Catalyst::Utils::env_at_action;
641 Assuming you have a request like GET /user/name:
643 In the example case C<$env> will have PATH_INFO of '/' instead of
644 '/user/name' and SCRIPT_NAME will now be '/user/name'.
646 Alternatively, assuming you have a request like GET /user/name/foo:
648 In this example case C<$env> will have PATH_INFO of '/foo' instead of
649 '/user/name/foo' and SCRIPT_NAME will now be '/user/name'.
651 This is probably a common case where you want to mount a PSGI application
652 under an action but let the Args fall through to the PSGI app.
658 my $argpath = join '/', @{$ctx->request->arguments};
659 my $path = '/' . $ctx->request->path;
661 $path =~ s/\/?\Q$argpath\E\/?$//;
663 my $env = $ctx->request->env;
664 my $path_info = $env->{PATH_INFO};
665 my $script_name = ($env->{SCRIPT_NAME} || '');
667 $path_info =~ s/(^\Q$path\E)//;
668 $script_name = "$script_name$1";
672 PATH_INFO => $path_info,
673 SCRIPT_NAME => $script_name };
676 =head2 env_at_request_uri
678 Localize C<$env> under the current request URI:
680 package MyApp::Controller::User;
684 use base 'Catalyst::Controller';
686 sub name :Local Args(1) {
687 my ($self, $c, $id) = @_;
688 my $env = $c->Catalyst::Utils::env_at_request_uri
691 Assuming you have a request like GET /user/name/hello:
693 In the example case C<$env> will have PATH_INFO of '/' instead of
694 '/user/name' and SCRIPT_NAME will now be '/user/name/hello'.
698 sub env_at_request_uri {
700 my $path = '/' . $ctx->request->path;
701 my $env = $ctx->request->env;
702 my $path_info = $env->{PATH_INFO};
703 my $script_name = ($env->{SCRIPT_NAME} || '');
705 $path_info =~ s/(^\Q$path\E)//;
706 $script_name = "$script_name$1";
710 PATH_INFO => $path_info,
711 SCRIPT_NAME => $script_name };
716 Catalyst Contributors, see Catalyst.pm
720 This library is free software. You can redistribute it and/or modify it under
721 the same terms as Perl itself.