1 package Catalyst::Utils;
4 use Catalyst::Exception;
15 Catalyst::Utils - The Catalyst Utils
27 =head2 appprefix($class)
29 MyApp::Foo becomes myapp_foo
40 =head2 class2appclass($class);
42 MyApp::Controller::Foo::Bar becomes MyApp
43 My::App::Controller::Foo::Bar becomes My::App
48 my $class = shift || '';
50 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
56 =head2 class2classprefix($class);
58 MyApp::Controller::Foo::Bar becomes MyApp::Controller
59 My::App::Controller::Foo::Bar becomes My::App::Controller
63 sub class2classprefix {
64 my $class = shift || '';
66 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
72 =head2 class2classsuffix($class);
74 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
78 sub class2classsuffix {
79 my $class = shift || '';
80 my $prefix = class2appclass($class) || '';
81 $class =~ s/$prefix\:://;
85 =head2 class2env($class);
87 Returns the environment name for class.
90 My::App becomes MY_APP
95 my $class = shift || '';
100 =head2 class2prefix( $class, $case );
102 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
104 My::App::Controller::Foo::Bar becomes foo/bar
109 my $class = shift || '';
110 my $case = shift || 0;
112 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
113 $prefix = $case ? $2 : lc $2;
114 $prefix =~ s{::}{/}g;
119 =head2 class2tempdir( $class [, $create ] );
121 Returns a tempdir for a class. If create is true it will try to create the path.
123 My::App becomes /tmp/my/app
124 My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
129 my $class = shift || '';
130 my $create = shift || 0;
131 my @parts = split '::', lc $class;
133 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
135 if ( $create && !-e $tmpdir ) {
137 eval { $tmpdir->mkpath };
140 Catalyst::Exception->throw(
141 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
145 return $tmpdir->stringify;
150 Returns home directory for given class.
157 # make an $INC{ $key } style string from the class name
158 (my $file = "$class.pm") =~ s{::}{/}g;
160 if ( my $inc_entry = $INC{$file} ) {
162 # look for an uninstalled Catalyst app
164 # find the @INC entry in which $file was found
165 (my $path = $inc_entry) =~ s/$file$//;
166 $path ||= cwd() if !defined $path || !length $path;
167 my $home = dir($path)->absolute->cleanup;
169 # pop off /lib and /blib if they're there
170 $home = $home->parent while $home =~ /b?lib$/;
172 # only return the dir if it has a Makefile.PL or Build.PL
173 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
175 # clean up relative path:
176 # MyApp/script/.. -> MyApp
179 my @dir_list = $home->dir_list();
180 while (($dir = pop(@dir_list)) && $dir eq '..') {
181 $home = dir($home)->parent->parent;
184 return $home->stringify;
189 # look for an installed Catalyst app
191 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
192 ( my $path = $inc_entry) =~ s/\.pm$//;
193 my $home = dir($path)->absolute->cleanup;
195 # return if if it's a valid directory
196 return $home->stringify if -d $home;
204 =head2 prefix($class, $name);
206 Returns a prefixed action.
208 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
213 my ( $class, $name ) = @_;
214 my $prefix = &class2prefix($class);
215 $name = "$prefix/$name" if $prefix;
221 Returns an L<HTTP::Request> object for a uri.
227 unless ( ref $request ) {
228 if ( $request =~ m/^http/i ) {
229 $request = URI->new($request);
232 $request = URI->new( 'http://localhost' . $request );
235 unless ( ref $request eq 'HTTP::Request' ) {
236 $request = HTTP::Request->new( 'GET', $request );
241 =head2 ensure_class_loaded($class_name, \%opts)
243 Loads the class unless it already has been loaded.
245 If $opts{ignore_loaded} is true always tries the require whether the package
246 already exists or not. Only pass this if you're either (a) sure you know the
247 file exists on disk or (b) have code to catch the file not found exception
248 that will result if it doesn't.
252 sub ensure_class_loaded {
256 croak "Malformed class Name $class"
257 if $class =~ m/(?:\b\:\b|\:{3,})/;
259 croak "Malformed class Name $class"
260 if $class =~ m/[^\w:]/;
262 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
263 if $class =~ m/\.pm$/;
265 return if !$opts->{ ignore_loaded }
266 && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again
268 # this hack is so we don't overwrite $@ if the load did not generate an error
272 my $file = $class . '.pm';
274 eval { CORE::require($file) };
278 die $error if $error;
279 die "require $class was successful but the package is not defined"
280 unless Class::Inspector->loaded($class);
285 =head2 merge_hashes($hashref, $hashref)
287 Base code to recursively merge two hashes together with right-hand precedence.
292 my ( $lefthash, $righthash ) = @_;
294 return $lefthash unless defined $righthash;
296 my %merged = %$lefthash;
297 for my $key ( keys %$righthash ) {
298 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
299 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
300 if( $right_ref and $left_ref ) {
301 $merged{ $key } = merge_hashes(
302 $lefthash->{ $key }, $righthash->{ $key }
306 $merged{ $key } = $righthash->{ $key };
313 =head2 env_value($class, $key)
315 Checks for and returns an environment value. For instance, if $key is
316 'home', then this method will check for and return the first value it finds,
317 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
322 my ( $class, $key ) = @_;
325 my @prefixes = ( class2env($class), 'CATALYST' );
327 for my $prefix (@prefixes) {
328 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
338 Try to guess terminal width to use with formatting of debug output
340 All you need to get this work, is:
342 1) Install Term::Size::Any, or
344 2) Export $COLUMNS from your shell.
346 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
347 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
348 that 'env' now lists COLUMNS.)
350 As last resort, default value of 80 chars will be used.
357 return $_term_width if $_term_width;
361 my ($columns, $rows) = Term::Size::Any::chars;
366 $width = $ENV{COLUMNS}
367 if exists($ENV{COLUMNS})
368 && $ENV{COLUMNS} =~ m/^\d+$/;
371 $width = 80 unless ($width && $width >= 80);
372 return $_term_width = $width;
377 Catalyst Contributors, see Catalyst.pm
381 This program is free software, you can redistribute it and/or modify it under
382 the same terms as Perl itself.