1 package Catalyst::Utils;
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 };
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 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 && Class::MOP::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 Class::MOP::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.
393 return $_term_width if $_term_width;
397 my ($columns, $rows) = Term::Size::Any::chars;
402 $width = $ENV{COLUMNS}
403 if exists($ENV{COLUMNS})
404 && $ENV{COLUMNS} =~ m/^\d+$/;
407 $width = 80 unless ($width && $width >= 80);
408 return $_term_width = $width;
412 =head2 resolve_namespace
414 Method which adds the namespace for plugins and actions.
416 __PACKAGE__->setup(qw(MyPlugin));
418 # will load Catalyst::Plugin::MyPlugin
423 sub resolve_namespace {
424 my $appnamespace = shift;
425 my $namespace = shift;
427 return String::RewritePrefix->rewrite({
428 q[] => qq[${namespace}::],
430 (defined $appnamespace
431 ? (q[~] => qq[${appnamespace}::])
437 =head2 build_middleware (@args)
439 Internal application that converts a single middleware definition (see
440 L<Catalyst/psgi_middleware>) into an actual instance of middleware.
444 sub build_middleware {
445 my ($class, $namespace, @init_args) = @_;
448 $namespace =~s/^\+// ||
449 $namespace =~/^Plack::Middleware/ ||
450 $namespace =~/^$class/
451 ) { ## the string is a full namespace
452 return Class::Load::try_load_class($namespace) ?
453 $namespace->new(@init_args) :
454 die "Can't load class $namespace";
455 } else { ## the string is a partial namespace
456 if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace
457 my $ns = $class .'::Middleware::'. $namespace;
458 return $ns->new(@init_args);
459 } elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder
460 return "Plack::Middleware::$namespace"->new(@init_args);
464 return; ## be sure we can count on a proper return when valid
467 =head2 apply_registered_middleware ($psgi)
469 Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares>
470 around it and return the wrapped version.
472 This exists to deal with the fact Catalyst registered middleware can be
473 either an object with a wrap method or a coderef.
477 sub apply_registered_middleware {
478 my ($class, $psgi) = @_;
479 my $new_psgi = $psgi;
480 foreach my $middleware ($class->registered_middlewares) {
481 $new_psgi = Scalar::Util::blessed $middleware ?
482 $middleware->wrap($new_psgi) :
483 $middleware->($new_psgi);
490 Catalyst Contributors, see Catalyst.pm
494 This library is free software. You can redistribute it and/or modify it under
495 the same terms as Perl itself.