1 package Catalyst::Utils;
10 use Class::Load 'is_class_loaded';
11 use String::RewritePrefix;
17 Catalyst::Utils - The Catalyst Utils
29 =head2 appprefix($class)
31 MyApp::Foo becomes myapp_foo
42 =head2 class2appclass($class);
44 MyApp::Controller::Foo::Bar becomes MyApp
45 My::App::Controller::Foo::Bar becomes My::App
50 my $class = shift || '';
52 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
58 =head2 class2classprefix($class);
60 MyApp::Controller::Foo::Bar becomes MyApp::Controller
61 My::App::Controller::Foo::Bar becomes My::App::Controller
65 sub class2classprefix {
66 my $class = shift || '';
68 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
74 =head2 class2classsuffix($class);
76 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
80 sub class2classsuffix {
81 my $class = shift || '';
82 my $prefix = class2appclass($class) || '';
83 $class =~ s/$prefix\:://;
87 =head2 class2env($class);
89 Returns the environment name for class.
92 My::App becomes MY_APP
97 my $class = shift || '';
102 =head2 class2prefix( $class, $case );
104 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
106 My::App::Controller::Foo::Bar becomes foo/bar
111 my $class = shift || '';
112 my $case = shift || 0;
114 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
115 $prefix = $case ? $2 : lc $2;
116 $prefix =~ s{::}{/}g;
121 =head2 class2tempdir( $class [, $create ] );
123 Returns a tempdir for a class. If create is true it will try to create the path.
125 My::App becomes /tmp/my/app
126 My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
131 my $class = shift || '';
132 my $create = shift || 0;
133 my @parts = split '::', lc $class;
135 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
137 if ( $create && !-e $tmpdir ) {
139 eval { $tmpdir->mkpath; 1 }
141 # don't load Catalyst::Exception as a BEGIN in Utils,
142 # because Utils often gets loaded before MyApp.pm, and if
143 # Catalyst::Exception is loaded before MyApp.pm, it does
145 # $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
147 require Catalyst::Exception;
148 Catalyst::Exception->throw(
149 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
153 return $tmpdir->stringify;
158 Returns home directory for given class.
160 =head2 dist_indicator_file_list
162 Returns a list of files which can be tested to check if you're inside
163 a CPAN distribution which is not yet installed.
181 sub dist_indicator_file_list {
182 qw{Makefile.PL Build.PL dist.ini cpanfile};
188 # make an $INC{ $key } style string from the class name
189 (my $file = "$class.pm") =~ s{::}{/}g;
191 if ( my $inc_entry = $INC{$file} ) {
193 # look for an uninstalled Catalyst app
195 # find the @INC entry in which $file was found
196 (my $path = $inc_entry) =~ s/$file$//;
197 $path ||= cwd() if !defined $path || !length $path;
198 my $home = dir($path)->absolute->cleanup;
200 # pop off /lib and /blib if they're there
201 $home = $home->parent while $home =~ /b?lib$/;
203 # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
204 if (grep { -f $home->file($_) } dist_indicator_file_list()) {
205 # clean up relative path:
206 # MyApp/script/.. -> MyApp
209 my @dir_list = $home->dir_list();
210 while (($dir = pop(@dir_list)) && $dir eq '..') {
211 $home = dir($home)->parent->parent;
214 return $home->stringify;
219 # look for an installed Catalyst app
221 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
222 ( my $path = $inc_entry) =~ s/\.pm$//;
223 my $home = dir($path)->absolute->cleanup;
225 # return if it's a valid directory
226 return $home->stringify if -d $home;
234 =head2 prefix($class, $name);
236 Returns a prefixed action.
238 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
243 my ( $class, $name ) = @_;
244 my $prefix = &class2prefix($class);
245 $name = "$prefix/$name" if $prefix;
251 Returns an L<HTTP::Request> object for a uri.
257 unless ( ref $request ) {
258 if ( $request =~ m/^http/i ) {
259 $request = URI->new($request);
262 $request = URI->new( 'http://localhost' . $request );
265 unless ( ref $request eq 'HTTP::Request' ) {
266 $request = HTTP::Request->new( 'GET', $request );
271 =head2 ensure_class_loaded($class_name, \%opts)
273 Loads the class unless it already has been loaded.
275 If $opts{ignore_loaded} is true always tries the require whether the package
276 already exists or not. Only pass this if you're either (a) sure you know the
277 file exists on disk or (b) have code to catch the file not found exception
278 that will result if it doesn't.
282 sub ensure_class_loaded {
286 croak "Malformed class Name $class"
287 if $class =~ m/(?:\b\:\b|\:{3,})/;
289 croak "Malformed class Name $class"
290 if $class =~ m/[^\w:]/;
292 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
293 if $class =~ m/\.pm$/;
295 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
296 # if it already has symbol table entries. This is to support things like Schema::Loader, which
297 # part-generate classes in memory, but then also load some of their contents from disk.
298 return if !$opts->{ ignore_loaded }
299 && is_class_loaded($class); # if a symbol entry exists we don't load again
301 # this hack is so we don't overwrite $@ if the load did not generate an error
305 my $file = $class . '.pm';
307 eval { CORE::require($file) };
311 die $error if $error;
313 warn "require $class was successful but the package is not defined."
314 unless is_class_loaded($class);
319 =head2 merge_hashes($hashref, $hashref)
321 Base code to recursively merge two hashes together with right-hand precedence.
326 my ( $lefthash, $righthash ) = @_;
328 return $lefthash unless defined $righthash;
330 my %merged = %$lefthash;
331 for my $key ( keys %$righthash ) {
332 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
333 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
334 if( $right_ref and $left_ref ) {
335 $merged{ $key } = merge_hashes(
336 $lefthash->{ $key }, $righthash->{ $key }
340 $merged{ $key } = $righthash->{ $key };
347 =head2 env_value($class, $key)
349 Checks for and returns an environment value. For instance, if $key is
350 'home', then this method will check for and return the first value it finds,
351 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
356 my ( $class, $key ) = @_;
359 my @prefixes = ( class2env($class), 'CATALYST' );
361 for my $prefix (@prefixes) {
362 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
372 Try to guess terminal width to use with formatting of debug output
374 All you need to get this work, is:
376 1) Install Term::Size::Any, or
378 2) Export $COLUMNS from your shell.
380 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
381 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
382 that 'env' now lists COLUMNS.)
384 As last resort, default value of 80 chars will be used.
386 Calling C<term_width> with a true value will cause it to be recalculated; you
387 can use this to cause it to get recalculated when your terminal is resized like
390 $SIG{WINCH} = sub { Catalyst::Utils::term_width(1) };
397 my $force_reset = shift;
399 undef $_term_width if $force_reset;
401 return $_term_width if $_term_width;
406 ($width) = Term::Size::Any::chars;
409 if($@ =~m[Can't locate Term/Size/Any.pm]) {
410 warn "Term::Size::Any is not installed, can't autodetect terminal column width\n";
412 warn "There was an error trying to detect your terminal size: $@\n";
414 warn 'Trouble trying to detect your terminal size, looking at $ENV{COLUMNS}'."\n";
415 $width = $ENV{COLUMNS}
416 if exists($ENV{COLUMNS})
417 && $ENV{COLUMNS} =~ m/^\d+$/;
421 warn "Cannot determine desired terminal width, using default of 80 columns\n";
422 $width = 80 } unless ($width && $width >= 80);
423 return $_term_width = $width;
427 =head2 resolve_namespace
429 Method which adds the namespace for plugins and actions.
431 __PACKAGE__->setup(qw(MyPlugin));
433 # will load Catalyst::Plugin::MyPlugin
438 sub resolve_namespace {
439 my $appnamespace = shift;
440 my $namespace = shift;
442 return String::RewritePrefix->rewrite({
443 q[] => qq[${namespace}::],
445 (defined $appnamespace
446 ? (q[~] => qq[${appnamespace}::])
452 =head2 build_middleware (@args)
454 Internal application that converts a single middleware definition (see
455 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
459 sub build_middleware {
460 my ($class, $namespace, @init_args) = @_;
463 $namespace =~s/^\+// ||
464 $namespace =~/^Plack::Middleware/ ||
465 $namespace =~/^$class/
466 ) { ## the string is a full namespace
467 return Class::Load::try_load_class($namespace) ?
468 $namespace->new(@init_args) :
469 die "Can't load class $namespace";
470 } else { ## the string is a partial namespace
471 if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
472 my $ns = $class .'::Middleware::'. $namespace;
473 return $ns->new(@init_args);
474 } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
475 return "Plack::Middleware::$namespace"->new(@init_args);
477 die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace";
481 return; ## be sure we can count on a proper return when valid
484 =head2 apply_registered_middleware ($psgi)
486 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
487 around it and return the wrapped version.
489 This exists to deal with the fact Catalyst registered middleware can be
490 either an object with a wrap method or a coderef.
494 sub apply_registered_middleware {
495 my ($class, $psgi) = @_;
496 my $new_psgi = $psgi;
497 foreach my $middleware ($class->registered_middlewares) {
498 $new_psgi = Scalar::Util::blessed $middleware ?
499 $middleware->wrap($new_psgi) :
500 $middleware->($new_psgi);
509 Utility functions to make it easier to work with PSGI applications under Catalyst
511 =head2 env_at_path_prefix
513 Localize C<$env> under the current controller path prefix:
515 package MyApp::Controller::User;
519 use base 'Catalyst::Controller';
523 my $env = $c->Catalyst::Utils::env_at_path_prefix;
526 Assuming you have a request like GET /user/name:
528 In the example case C<$env> will have PATH_INFO of '/name' instead of
529 '/user/name' and SCRIPT_NAME will now be '/user'.
533 sub env_at_path_prefix {
535 my $path_prefix = $ctx->controller->path_prefix;
536 my $env = $ctx->request->env;
537 my $path_info = $env->{PATH_INFO};
538 my $script_name = ($env->{SCRIPT_NAME} || '');
540 $path_info =~ s/(^\/\Q$path_prefix\E)//;
541 $script_name = "$script_name$1";
545 PATH_INFO => $path_info,
546 SCRIPT_NAME => $script_name };
551 Localize C<$env> under the current action namespace.
553 package MyApp::Controller::User;
557 use base 'Catalyst::Controller';
561 my $env = $c->Catalyst::Utils::env_at_action;
564 Assuming you have a request like GET /user/name:
566 In the example case C<$env> will have PATH_INFO of '/' instead of
567 '/user/name' and SCRIPT_NAME will now be '/user/name'.
569 Alternatively, assuming you have a request like GET /user/name/foo:
571 In this example case C<$env> will have PATH_INFO of '/foo' instead of
572 '/user/name/foo' and SCRIPT_NAME will now be '/user/name'.
574 This is probably a common case where you want to mount a PSGI application
575 under an action but let the Args fall through to the PSGI app.
581 my $argpath = join '/', @{$ctx->request->arguments};
582 my $path = '/' . $ctx->request->path;
584 $path =~ s/\/?\Q$argpath\E\/?$//;
586 my $env = $ctx->request->env;
587 my $path_info = $env->{PATH_INFO};
588 my $script_name = ($env->{SCRIPT_NAME} || '');
590 $path_info =~ s/(^\Q$path\E)//;
591 $script_name = "$script_name$1";
595 PATH_INFO => $path_info,
596 SCRIPT_NAME => $script_name };
599 =head2 env_at_request_uri
601 Localize C<$env> under the current request URI:
603 package MyApp::Controller::User;
607 use base 'Catalyst::Controller';
609 sub name :Local Args(1) {
610 my ($self, $c, $id) = @_;
611 my $env = $c->Catalyst::Utils::env_at_request_uri
614 Assuming you have a request like GET /user/name/hello:
616 In the example case C<$env> will have PATH_INFO of '/' instead of
617 '/user/name' and SCRIPT_NAME will now be '/user/name/hello'.
621 sub env_at_request_uri {
623 my $path = '/' . $ctx->request->path;
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\E)//;
629 $script_name = "$script_name$1";
633 PATH_INFO => $path_info,
634 SCRIPT_NAME => $script_name };
639 Catalyst Contributors, see Catalyst.pm
643 This library is free software. You can redistribute it and/or modify it under
644 the same terms as Perl itself.