1 package Catalyst::Utils;
4 use Catalyst::Exception;
16 Catalyst::Utils - The Catalyst Utils
28 =head2 appprefix($class)
30 MyApp::Foo becomes myapp_foo
41 =head2 class2appclass($class);
43 MyApp::Controller::Foo::Bar becomes MyApp
44 My::App::Controller::Foo::Bar becomes My::App
49 my $class = shift || '';
51 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
57 =head2 class2classprefix($class);
59 MyApp::Controller::Foo::Bar becomes MyApp::Controller
60 My::App::Controller::Foo::Bar becomes My::App::Controller
64 sub class2classprefix {
65 my $class = shift || '';
67 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
73 =head2 class2classsuffix($class);
75 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
79 sub class2classsuffix {
80 my $class = shift || '';
81 my $prefix = class2appclass($class) || '';
82 $class =~ s/$prefix\:://;
86 =head2 class2env($class);
88 Returns the environment name for class.
91 My::App becomes MY_APP
96 my $class = shift || '';
101 =head2 class2prefix( $class, $case );
103 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
105 My::App::Controller::Foo::Bar becomes foo/bar
110 my $class = shift || '';
111 my $case = shift || 0;
113 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
114 $prefix = $case ? $2 : lc $2;
115 $prefix =~ s{::}{/}g;
120 =head2 class2tempdir( $class [, $create ] );
122 Returns a tempdir for a class. If create is true it will try to create the path.
124 My::App becomes /tmp/my/app
125 My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
130 my $class = shift || '';
131 my $create = shift || 0;
132 my @parts = split '::', lc $class;
134 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
136 if ( $create && !-e $tmpdir ) {
138 eval { $tmpdir->mkpath };
141 Catalyst::Exception->throw(
142 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
146 return $tmpdir->stringify;
151 Returns home directory for given class.
158 # make an $INC{ $key } style string from the class name
159 (my $file = "$class.pm") =~ s{::}{/}g;
161 if ( my $inc_entry = $INC{$file} ) {
163 # look for an uninstalled Catalyst app
165 # find the @INC entry in which $file was found
166 (my $path = $inc_entry) =~ s/$file$//;
167 $path ||= cwd() if !defined $path || !length $path;
168 my $home = dir($path)->absolute->cleanup;
170 # pop off /lib and /blib if they're there
171 $home = $home->parent while $home =~ /b?lib$/;
173 # only return the dir if it has a Makefile.PL or Build.PL
174 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
176 # clean up relative path:
177 # MyApp/script/.. -> MyApp
180 my @dir_list = $home->dir_list();
181 while (($dir = pop(@dir_list)) && $dir eq '..') {
182 $home = dir($home)->parent->parent;
185 return $home->stringify;
190 # look for an installed Catalyst app
192 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
193 ( my $path = $inc_entry) =~ s/\.pm$//;
194 my $home = dir($path)->absolute->cleanup;
196 # return if if it's a valid directory
197 return $home->stringify if -d $home;
205 =head2 prefix($class, $name);
207 Returns a prefixed action.
209 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
214 my ( $class, $name ) = @_;
215 my $prefix = &class2prefix($class);
216 $name = "$prefix/$name" if $prefix;
222 Returns an L<HTTP::Request> object for a uri.
228 unless ( ref $request ) {
229 if ( $request =~ m/^http/i ) {
230 $request = URI->new($request);
233 $request = URI->new( 'http://localhost' . $request );
236 unless ( ref $request eq 'HTTP::Request' ) {
237 $request = HTTP::Request->new( 'GET', $request );
242 =head2 ensure_class_loaded($class_name, \%opts)
244 Loads the class unless it already has been loaded.
246 If $opts{ignore_loaded} is true always tries the require whether the package
247 already exists or not. Only pass this if you're either (a) sure you know the
248 file exists on disk or (b) have code to catch the file not found exception
249 that will result if it doesn't.
253 sub ensure_class_loaded {
257 croak "Malformed class Name $class"
258 if $class =~ m/(?:\b\:\b|\:{3,})/;
260 croak "Malformed class Name $class"
261 if $class =~ m/[^\w:]/;
263 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
264 if $class =~ m/\.pm$/;
266 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
267 # if it already has symbol table entries. This is to support things like Schema::Loader, which
268 # part-generate classes in memory, but then also load some of their contents from disk.
269 return if !$opts->{ ignore_loaded }
270 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
272 # this hack is so we don't overwrite $@ if the load did not generate an error
276 my $file = $class . '.pm';
278 eval { CORE::require($file) };
282 die $error if $error;
284 warn "require $class was successful but the package is not defined."
285 unless Class::MOP::is_class_loaded($class);
290 =head2 merge_hashes($hashref, $hashref)
292 Base code to recursively merge two hashes together with right-hand precedence.
297 my ( $lefthash, $righthash ) = @_;
299 return $lefthash unless defined $righthash;
301 my %merged = %$lefthash;
302 for my $key ( keys %$righthash ) {
303 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
304 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
305 if( $right_ref and $left_ref ) {
306 $merged{ $key } = merge_hashes(
307 $lefthash->{ $key }, $righthash->{ $key }
311 $merged{ $key } = $righthash->{ $key };
318 =head2 env_value($class, $key)
320 Checks for and returns an environment value. For instance, if $key is
321 'home', then this method will check for and return the first value it finds,
322 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
327 my ( $class, $key ) = @_;
330 my @prefixes = ( class2env($class), 'CATALYST' );
332 for my $prefix (@prefixes) {
333 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
343 Try to guess terminal width to use with formatting of debug output
345 All you need to get this work, is:
347 1) Install Term::Size::Any, or
349 2) Export $COLUMNS from your shell.
351 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
352 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
353 that 'env' now lists COLUMNS.)
355 As last resort, default value of 80 chars will be used.
362 return $_term_width if $_term_width;
366 my ($columns, $rows) = Term::Size::Any::chars;
371 $width = $ENV{COLUMNS}
372 if exists($ENV{COLUMNS})
373 && $ENV{COLUMNS} =~ m/^\d+$/;
376 $width = 80 unless ($width && $width >= 80);
377 return $_term_width = $width;
382 Catalyst Contributors, see Catalyst.pm
386 This library is free software. You can redistribute it and/or modify it under
387 the same terms as Perl itself.