1 package Catalyst::Utils;
10 use Class::Load 'is_class_loaded';
11 use String::RewritePrefix;
18 Catalyst::Utils - The Catalyst Utils
30 =head2 appprefix($class)
32 MyApp::Foo becomes myapp_foo
43 =head2 class2appclass($class);
45 MyApp::Controller::Foo::Bar becomes MyApp
46 My::App::Controller::Foo::Bar becomes My::App
51 my $class = shift || '';
53 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
59 =head2 class2classprefix($class);
61 MyApp::Controller::Foo::Bar becomes MyApp::Controller
62 My::App::Controller::Foo::Bar becomes My::App::Controller
66 sub class2classprefix {
67 my $class = shift || '';
69 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
75 =head2 class2classsuffix($class);
77 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
81 sub class2classsuffix {
82 my $class = shift || '';
83 my $prefix = class2appclass($class) || '';
84 $class =~ s/$prefix\:://;
88 =head2 class2env($class);
90 Returns the environment name for class.
93 My::App becomes MY_APP
98 my $class = shift || '';
103 =head2 class2prefix( $class, $case );
105 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
107 My::App::Controller::Foo::Bar becomes foo/bar
112 my $class = shift || '';
113 my $case = shift || 0;
115 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
116 $prefix = $case ? $2 : lc $2;
117 $prefix =~ s{::}{/}g;
122 =head2 class2tempdir( $class [, $create ] );
124 Returns a tempdir for a class. If create is true it will try to create the path.
126 My::App becomes /tmp/my/app
127 My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
132 my $class = shift || '';
133 my $create = shift || 0;
134 my @parts = split '::', lc $class;
136 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
138 if ( $create && !-e $tmpdir ) {
140 eval { $tmpdir->mkpath; 1 }
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
146 # $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
148 require Catalyst::Exception;
149 Catalyst::Exception->throw(
150 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
154 return $tmpdir->stringify;
159 Returns home directory for given class.
161 =head2 dist_indicator_file_list
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.
182 sub dist_indicator_file_list {
183 qw{Makefile.PL Build.PL dist.ini cpanfile};
189 # make an $INC{ $key } style string from the class name
190 (my $file = "$class.pm") =~ s{::}{/}g;
192 if ( my $inc_entry = $INC{$file} ) {
194 # look for an uninstalled Catalyst app
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;
201 # pop off /lib and /blib if they're there
202 $home = $home->parent while $home =~ /b?lib$/;
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
210 my @dir_list = $home->dir_list();
211 while (($dir = pop(@dir_list)) && $dir eq '..') {
212 $home = dir($home)->parent->parent;
215 return $home->stringify;
220 # look for an installed Catalyst app
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;
226 # return if it's a valid directory
227 return $home->stringify if -d $home;
235 =head2 prefix($class, $name);
237 Returns a prefixed action.
239 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
244 my ( $class, $name ) = @_;
245 my $prefix = &class2prefix($class);
246 $name = "$prefix/$name" if $prefix;
252 Returns an L<HTTP::Request> object for a uri.
258 unless ( ref $request ) {
259 if ( $request =~ m/^http/i ) {
260 $request = URI->new($request);
263 $request = URI->new( 'http://localhost' . $request );
266 unless ( ref $request eq 'HTTP::Request' ) {
267 $request = HTTP::Request->new( 'GET', $request );
272 =head2 ensure_class_loaded($class_name, \%opts)
274 Loads the class unless it already has been loaded.
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.
283 sub ensure_class_loaded {
287 croak "Malformed class Name $class"
288 if $class =~ m/(?:\b\:\b|\:{3,})/;
290 croak "Malformed class Name $class"
291 if $class =~ m/[^\w:]/;
293 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
294 if $class =~ m/\.pm$/;
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
302 # this hack is so we don't overwrite $@ if the load did not generate an error
306 my $file = $class . '.pm';
308 eval { CORE::require($file) };
312 die $error if $error;
314 warn "require $class was successful but the package is not defined."
315 unless is_class_loaded($class);
320 =head2 merge_hashes($hashref, $hashref)
322 Base code to recursively merge two hashes together with right-hand precedence.
327 my ( $lefthash, $righthash ) = @_;
329 return $lefthash unless defined $righthash;
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 }
341 $merged{ $key } = $righthash->{ $key };
348 =head2 env_value($class, $key)
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}.
357 my ( $class, $key ) = @_;
360 my @prefixes = ( class2env($class), 'CATALYST' );
362 for my $prefix (@prefixes) {
363 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
373 Try to guess terminal width to use with formatting of debug output
375 All you need to get this work, is:
377 1) Install Term::Size::Any, or
379 2) Export $COLUMNS from your shell.
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.)
385 As last resort, default value of 80 chars will be used.
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
391 $SIG{WINCH} = sub { Catalyst::Utils::term_width(1) };
398 my $force_reset = shift;
400 undef $_term_width if $force_reset;
402 return $_term_width if $_term_width;
407 ($width) = Term::Size::Any::chars;
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";
413 warn "There was an error trying to detect your terminal size: $@\n";
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+$/;
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;
428 =head2 resolve_namespace
430 Method which adds the namespace for plugins and actions.
432 __PACKAGE__->setup(qw(MyPlugin));
434 # will load Catalyst::Plugin::MyPlugin
439 sub resolve_namespace {
440 my $appnamespace = shift;
441 my $namespace = shift;
443 return String::RewritePrefix->rewrite({
444 q[] => qq[${namespace}::],
446 (defined $appnamespace
447 ? (q[~] => qq[${appnamespace}::])
453 =head2 build_middleware (@args)
455 Internal application that converts a single middleware definition (see
456 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
460 sub build_middleware {
461 my ($class, $namespace, @init_args) = @_;
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);
478 die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
482 return; ## be sure we can count on a proper return when valid
485 =head2 apply_registered_middleware ($psgi)
487 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
488 around it and return the wrapped version.
490 This exists to deal with the fact Catalyst registered middleware can be
491 either an object with a wrap method or a coderef.
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);
508 Utility functions to make it easier to work with PSGI applications under Catalyst
510 =head2 env_at_path_prefix
512 Localize C<$env> under the current controller path prefix:
514 package MyApp::Controller::User;
518 use base 'Catalyst::Controller';
522 my $env = $c->Catalyst::Utils::env_at_path_prefix;
525 Assuming you have a request like GET /user/name:
527 In the example case C<$env> will have PATH_INFO of '/name' instead of
528 '/user/name' and SCRIPT_NAME will now be '/user'.
532 sub env_at_path_prefix {
534 my $path_prefix = $ctx->controller->path_prefix;
535 my $env = $ctx->request->env;
536 my $path_info = $env->{PATH_INFO};
537 my $script_name = ($env->{SCRIPT_NAME} || '');
539 $path_info =~ s/(^\/\Q$path_prefix\E)//;
540 $script_name = "$script_name$1";
544 PATH_INFO => $path_info,
545 SCRIPT_NAME => $script_name };
550 Localize C<$env> under the current action namespace.
552 package MyApp::Controller::User;
556 use base 'Catalyst::Controller';
560 my $env = $c->Catalyst::Utils::env_at_action;
563 Assuming you have a request like GET /user/name:
565 In the example case C<$env> will have PATH_INFO of '/' instead of
566 '/user/name' and SCRIPT_NAME will now be '/user/name'.
568 Alternatively, assuming you have a request like GET /user/name/foo:
570 In this example case C<$env> will have PATH_INFO of '/foo' instead of
571 '/user/name/foo' and SCRIPT_NAME will now be '/user/name'.
573 This is probably a common case where you want to mount a PSGI application
574 under an action but let the Args fall through to the PSGI app.
580 my $argpath = join '/', @{$ctx->request->arguments};
581 my $path = '/' . $ctx->request->path;
583 $path =~ s/\/?\Q$argpath\E\/?$//;
585 my $env = $ctx->request->env;
586 my $path_info = $env->{PATH_INFO};
587 my $script_name = ($env->{SCRIPT_NAME} || '');
589 $path_info =~ s/(^\Q$path\E)//;
590 $script_name = "$script_name$1";
594 PATH_INFO => $path_info,
595 SCRIPT_NAME => $script_name };
598 =head2 env_at_request_uri
600 Localize C<$env> under the current request URI:
602 package MyApp::Controller::User;
606 use base 'Catalyst::Controller';
608 sub name :Local Args(1) {
609 my ($self, $c, $id) = @_;
610 my $env = $c->Catalyst::Utils::env_at_request_uri
613 Assuming you have a request like GET /user/name/hello:
615 In the example case C<$env> will have PATH_INFO of '/' instead of
616 '/user/name' and SCRIPT_NAME will now be '/user/name/hello'.
620 sub env_at_request_uri {
622 my $path = '/' . $ctx->request->path;
623 my $env = $ctx->request->env;
624 my $path_info = $env->{PATH_INFO};
625 my $script_name = ($env->{SCRIPT_NAME} || '');
627 $path_info =~ s/(^\Q$path\E)//;
628 $script_name = "$script_name$1";
632 PATH_INFO => $path_info,
633 SCRIPT_NAME => $script_name };
638 Catalyst Contributors, see Catalyst.pm
642 This library is free software. You can redistribute it and/or modify it under
643 the same terms as Perl itself.