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 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.
391 return $_term_width if $_term_width;
395 require Term::Size::Any;
396 my ($columns, $rows) = Term::Size::Any::chars;
400 $width = $ENV{COLUMNS}
401 if exists($ENV{COLUMNS})
402 && $ENV{COLUMNS} =~ m/^\d+$/;
405 $width = 80 unless ($width && $width >= 80);
406 return $_term_width = $width;
410 =head2 resolve_namespace
412 Method which adds the namespace for plugins and actions.
414 __PACKAGE__->setup(qw(MyPlugin));
416 # will load Catalyst::Plugin::MyPlugin
421 sub resolve_namespace {
422 my $appnamespace = shift;
423 my $namespace = shift;
425 return String::RewritePrefix->rewrite({
426 q[] => qq[${namespace}::],
428 (defined $appnamespace
429 ? (q[~] => qq[${appnamespace}::])
438 Catalyst Contributors, see Catalyst.pm
442 This library is free software. You can redistribute it and/or modify it under
443 the same terms as Perl itself.