1 package Catalyst::Utils;
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 class2classshortsuffix($class)
89 MyApp::Controller::Foo::Bar becomes Foo::Bar
93 sub class2classshortsuffix {
94 my $class = shift || '';
95 my $prefix = class2classprefix($class) || '';
96 $class =~ s/$prefix\:://;
101 =head2 class2env($class);
103 Returns the environment name for class.
106 My::App becomes MY_APP
111 my $class = shift || '';
116 =head2 class2prefix( $class, $case );
118 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
120 My::App::Controller::Foo::Bar becomes foo/bar
125 my $class = shift || '';
126 my $case = shift || 0;
128 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
129 $prefix = $case ? $2 : lc $2;
130 $prefix =~ s{::}{/}g;
135 =head2 class2tempdir( $class [, $create ] );
137 Returns a tempdir for a class. If create is true it will try to create the path.
139 My::App becomes /tmp/my/app
140 My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
145 my $class = shift || '';
146 my $create = shift || 0;
147 my @parts = split '::', lc $class;
149 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
151 if ( $create && !-e $tmpdir ) {
153 eval { $tmpdir->mkpath };
156 # don't load Catalyst::Exception as a BEGIN in Utils,
157 # because Utils often gets loaded before MyApp.pm, and if
158 # Catalyst::Exception is loaded before MyApp.pm, it does
160 # $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
162 require Catalyst::Exception;
163 Catalyst::Exception->throw(
164 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
168 return $tmpdir->stringify;
173 Returns home directory for given class.
175 =head2 dist_indicator_file_list
177 Returns a list of files which can be tested to check if you're inside
178 a CPAN distribution which is not yet installed.
194 sub dist_indicator_file_list {
195 qw{Makefile.PL Build.PL dist.ini};
201 # make an $INC{ $key } style string from the class name
202 (my $file = "$class.pm") =~ s{::}{/}g;
204 if ( my $inc_entry = $INC{$file} ) {
206 # look for an uninstalled Catalyst app
208 # find the @INC entry in which $file was found
209 (my $path = $inc_entry) =~ s/$file$//;
210 $path ||= cwd() if !defined $path || !length $path;
211 my $home = dir($path)->absolute->cleanup;
213 # pop off /lib and /blib if they're there
214 $home = $home->parent while $home =~ /b?lib$/;
216 # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
217 if (grep { -f $home->file($_) } dist_indicator_file_list()) {
218 # clean up relative path:
219 # MyApp/script/.. -> MyApp
222 my @dir_list = $home->dir_list();
223 while (($dir = pop(@dir_list)) && $dir eq '..') {
224 $home = dir($home)->parent->parent;
227 return $home->stringify;
232 # look for an installed Catalyst app
234 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
235 ( my $path = $inc_entry) =~ s/\.pm$//;
236 my $home = dir($path)->absolute->cleanup;
238 # return if if it's a valid directory
239 return $home->stringify if -d $home;
247 =head2 prefix($class, $name);
249 Returns a prefixed action.
251 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
256 my ( $class, $name ) = @_;
257 my $prefix = &class2prefix($class);
258 $name = "$prefix/$name" if $prefix;
264 Returns an L<HTTP::Request> object for a uri.
270 unless ( ref $request ) {
271 if ( $request =~ m/^http/i ) {
272 $request = URI->new($request);
275 $request = URI->new( 'http://localhost' . $request );
278 unless ( ref $request eq 'HTTP::Request' ) {
279 $request = HTTP::Request->new( 'GET', $request );
284 =head2 ensure_class_loaded($class_name, \%opts)
286 Loads the class unless it already has been loaded.
288 If $opts{ignore_loaded} is true always tries the require whether the package
289 already exists or not. Only pass this if you're either (a) sure you know the
290 file exists on disk or (b) have code to catch the file not found exception
291 that will result if it doesn't.
295 sub ensure_class_loaded {
299 croak "Malformed class Name $class"
300 if $class =~ m/(?:\b\:\b|\:{3,})/;
302 croak "Malformed class Name $class"
303 if $class =~ m/[^\w:]/;
305 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
306 if $class =~ m/\.pm$/;
308 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
309 # if it already has symbol table entries. This is to support things like Schema::Loader, which
310 # part-generate classes in memory, but then also load some of their contents from disk.
311 return if !$opts->{ ignore_loaded }
312 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
314 # this hack is so we don't overwrite $@ if the load did not generate an error
318 my $file = $class . '.pm';
320 eval { CORE::require($file) };
324 die $error if $error;
326 warn "require $class was successful but the package is not defined."
327 unless Class::MOP::is_class_loaded($class);
332 =head2 merge_hashes($hashref, $hashref)
334 Base code to recursively merge two hashes together with right-hand precedence.
339 my ( $lefthash, $righthash ) = @_;
341 return $lefthash unless defined $righthash;
343 my %merged = %$lefthash;
344 for my $key ( keys %$righthash ) {
345 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
346 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
347 if( $right_ref and $left_ref ) {
348 $merged{ $key } = merge_hashes(
349 $lefthash->{ $key }, $righthash->{ $key }
353 $merged{ $key } = $righthash->{ $key };
360 =head2 env_value($class, $key)
362 Checks for and returns an environment value. For instance, if $key is
363 'home', then this method will check for and return the first value it finds,
364 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
369 my ( $class, $key ) = @_;
372 my @prefixes = ( class2env($class), 'CATALYST' );
374 for my $prefix (@prefixes) {
375 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
385 Try to guess terminal width to use with formatting of debug output
387 All you need to get this work, is:
389 1) Install Term::Size::Any, or
391 2) Export $COLUMNS from your shell.
393 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
394 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
395 that 'env' now lists COLUMNS.)
397 As last resort, default value of 80 chars will be used.
404 return $_term_width if $_term_width;
408 my ($columns, $rows) = Term::Size::Any::chars;
413 $width = $ENV{COLUMNS}
414 if exists($ENV{COLUMNS})
415 && $ENV{COLUMNS} =~ m/^\d+$/;
418 $width = 80 unless ($width && $width >= 80);
419 return $_term_width = $width;
423 =head2 resolve_namespace
425 Method which adds the namespace for plugins and actions.
427 __PACKAGE__->setup(qw(MyPlugin));
429 # will load Catalyst::Plugin::MyPlugin
434 sub resolve_namespace {
435 my $appnamespace = shift;
436 my $namespace = shift;
438 return String::RewritePrefix->rewrite({
439 q[] => qq[${namespace}::],
441 (defined $appnamespace
442 ? (q[~] => qq[${appnamespace}::])
451 Catalyst Contributors, see Catalyst.pm
455 This library is free software. You can redistribute it and/or modify it under
456 the same terms as Perl itself.