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.
180 # make an $INC{ $key } style string from the class name
181 (my $file = "$class.pm") =~ s{::}{/}g;
183 if ( my $inc_entry = $INC{$file} ) {
185 # look for an uninstalled Catalyst app
187 # find the @INC entry in which $file was found
188 (my $path = $inc_entry) =~ s/$file$//;
189 $path ||= cwd() if !defined $path || !length $path;
190 my $home = dir($path)->absolute->cleanup;
192 # pop off /lib and /blib if they're there
193 $home = $home->parent while $home =~ /b?lib$/;
195 # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
196 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")
197 or -f $home->file("dist.ini")) {
199 # clean up relative path:
200 # MyApp/script/.. -> MyApp
203 my @dir_list = $home->dir_list();
204 while (($dir = pop(@dir_list)) && $dir eq '..') {
205 $home = dir($home)->parent->parent;
208 return $home->stringify;
213 # look for an installed Catalyst app
215 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
216 ( my $path = $inc_entry) =~ s/\.pm$//;
217 my $home = dir($path)->absolute->cleanup;
219 # return if if it's a valid directory
220 return $home->stringify if -d $home;
228 =head2 prefix($class, $name);
230 Returns a prefixed action.
232 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
237 my ( $class, $name ) = @_;
238 my $prefix = &class2prefix($class);
239 $name = "$prefix/$name" if $prefix;
245 Returns an L<HTTP::Request> object for a uri.
251 unless ( ref $request ) {
252 if ( $request =~ m/^http/i ) {
253 $request = URI->new($request);
256 $request = URI->new( 'http://localhost' . $request );
259 unless ( ref $request eq 'HTTP::Request' ) {
260 $request = HTTP::Request->new( 'GET', $request );
265 =head2 ensure_class_loaded($class_name, \%opts)
267 Loads the class unless it already has been loaded.
269 If $opts{ignore_loaded} is true always tries the require whether the package
270 already exists or not. Only pass this if you're either (a) sure you know the
271 file exists on disk or (b) have code to catch the file not found exception
272 that will result if it doesn't.
276 sub ensure_class_loaded {
280 croak "Malformed class Name $class"
281 if $class =~ m/(?:\b\:\b|\:{3,})/;
283 croak "Malformed class Name $class"
284 if $class =~ m/[^\w:]/;
286 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
287 if $class =~ m/\.pm$/;
289 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
290 # if it already has symbol table entries. This is to support things like Schema::Loader, which
291 # part-generate classes in memory, but then also load some of their contents from disk.
292 return if !$opts->{ ignore_loaded }
293 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
295 # this hack is so we don't overwrite $@ if the load did not generate an error
299 my $file = $class . '.pm';
301 eval { CORE::require($file) };
305 die $error if $error;
307 warn "require $class was successful but the package is not defined."
308 unless Class::MOP::is_class_loaded($class);
313 =head2 merge_hashes($hashref, $hashref)
315 Base code to recursively merge two hashes together with right-hand precedence.
320 my ( $lefthash, $righthash ) = @_;
322 return $lefthash unless defined $righthash;
324 my %merged = %$lefthash;
325 for my $key ( keys %$righthash ) {
326 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
327 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
328 if( $right_ref and $left_ref ) {
329 $merged{ $key } = merge_hashes(
330 $lefthash->{ $key }, $righthash->{ $key }
334 $merged{ $key } = $righthash->{ $key };
341 =head2 env_value($class, $key)
343 Checks for and returns an environment value. For instance, if $key is
344 'home', then this method will check for and return the first value it finds,
345 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
350 my ( $class, $key ) = @_;
353 my @prefixes = ( class2env($class), 'CATALYST' );
355 for my $prefix (@prefixes) {
356 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
366 Try to guess terminal width to use with formatting of debug output
368 All you need to get this work, is:
370 1) Install Term::Size::Any, or
372 2) Export $COLUMNS from your shell.
374 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
375 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
376 that 'env' now lists COLUMNS.)
378 As last resort, default value of 80 chars will be used.
385 return $_term_width if $_term_width;
389 my ($columns, $rows) = Term::Size::Any::chars;
394 $width = $ENV{COLUMNS}
395 if exists($ENV{COLUMNS})
396 && $ENV{COLUMNS} =~ m/^\d+$/;
399 $width = 80 unless ($width && $width >= 80);
400 return $_term_width = $width;
404 =head2 resolve_namespace
406 Method which adds the namespace for plugins and actions.
408 __PACKAGE__->setup(qw(MyPlugin));
410 # will load Catalyst::Plugin::MyPlugin
415 sub resolve_namespace {
416 my $appnamespace = shift;
417 my $namespace = shift;
419 return String::RewritePrefix->rewrite({
420 q[] => qq[${namespace}::],
422 (defined $appnamespace
423 ? (q[~] => qq[${appnamespace}::])
432 Catalyst Contributors, see Catalyst.pm
436 This library is free software. You can redistribute it and/or modify it under
437 the same terms as Perl itself.