1 package Catalyst::Utils;
4 use Catalyst::Exception;
14 Catalyst::Utils - The Catalyst Utils
26 =head2 appprefix($class)
28 MyApp::Foo becomes myapp_foo
39 =head2 class2appclass($class);
41 MyApp::Controller::Foo::Bar becomes MyApp
42 My::App::Controller::Foo::Bar becomes My::App
47 my $class = shift || '';
49 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
55 =head2 class2classprefix($class);
57 MyApp::Controller::Foo::Bar becomes MyApp::Controller
58 My::App::Controller::Foo::Bar becomes My::App::Controller
62 sub class2classprefix {
63 my $class = shift || '';
65 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
71 =head2 class2classsuffix($class);
73 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
77 sub class2classsuffix {
78 my $class = shift || '';
79 my $prefix = class2appclass($class) || '';
80 $class =~ s/$prefix\:://;
84 =head2 class2env($class);
86 Returns the environment name for class.
89 My::App becomes MY_APP
94 my $class = shift || '';
99 =head2 class2prefix( $class, $case );
101 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
103 My::App::Controller::Foo::Bar becomes foo/bar
108 my $class = shift || '';
109 my $case = shift || 0;
111 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
112 $prefix = $case ? $2 : lc $2;
113 $prefix =~ s{::}{/}g;
118 =head2 class2tempdir( $class [, $create ] );
120 Returns a tempdir for a class. If create is true it will try to create the path.
122 My::App becomes /tmp/my/app
123 My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
128 my $class = shift || '';
129 my $create = shift || 0;
130 my @parts = split '::', lc $class;
132 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
134 if ( $create && !-e $tmpdir ) {
136 eval { $tmpdir->mkpath };
139 Catalyst::Exception->throw(
140 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
144 return $tmpdir->stringify;
149 Returns home directory for given class.
156 # make an $INC{ $key } style string from the class name
157 (my $file = "$class.pm") =~ s{::}{/}g;
159 if ( my $inc_entry = $INC{$file} ) {
161 # look for an uninstalled Catalyst app
163 # find the @INC entry in which $file was found
164 (my $path = $inc_entry) =~ s/$file$//;
165 $path ||= cwd() if !defined $path || !length $path;
166 my $home = dir($path)->absolute->cleanup;
168 # pop off /lib and /blib if they're there
169 $home = $home->parent while $home =~ /b?lib$/;
171 # only return the dir if it has a Makefile.PL or Build.PL
172 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
174 # clean up relative path:
175 # MyApp/script/.. -> MyApp
178 my @dir_list = $home->dir_list();
179 while (($dir = pop(@dir_list)) && $dir eq '..') {
180 $home = dir($home)->parent->parent;
183 return $home->stringify;
188 # look for an installed Catalyst app
190 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
191 ( my $path = $inc_entry) =~ s/\.pm$//;
192 my $home = dir($path)->absolute->cleanup;
194 # return if if it's a valid directory
195 return $home->stringify if -d $home;
203 =head2 prefix($class, $name);
205 Returns a prefixed action.
207 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
212 my ( $class, $name ) = @_;
213 my $prefix = &class2prefix($class);
214 $name = "$prefix/$name" if $prefix;
220 Returns an L<HTTP::Request> object for a uri.
226 unless ( ref $request ) {
227 if ( $request =~ m/^http/i ) {
228 $request = URI->new($request);
231 $request = URI->new( 'http://localhost' . $request );
234 unless ( ref $request eq 'HTTP::Request' ) {
235 $request = HTTP::Request->new( 'GET', $request );
240 =head2 ensure_class_loaded($class_name, \%opts)
242 Loads the class unless it already has been loaded.
244 If $opts{ignore_loaded} is true always tries the require whether the package
245 already exists or not. Only pass this if you're either (a) sure you know the
246 file exists on disk or (b) have code to catch the file not found exception
247 that will result if it doesn't.
251 sub ensure_class_loaded {
255 croak "Malformed class Name $class"
256 if $class =~ m/(?:\b\:\b|\:{3,})/;
258 croak "Malformed class Name $class"
259 if $class =~ m/[^\w:]/;
261 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
262 if $class =~ m/\.pm$/;
264 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
265 # if it already has symbol table entries. This is to support things like Schema::Loader, which
266 # part-generate classes in memory, but then also load some of their contents from disk.
267 return if !$opts->{ ignore_loaded }
268 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
270 # this hack is so we don't overwrite $@ if the load did not generate an error
274 my $file = $class . '.pm';
276 eval { CORE::require($file) };
280 die $error if $error;
282 warn "require $class was successful but the package is not defined."
283 unless Class::MOP::is_class_loaded($class);
288 =head2 merge_hashes($hashref, $hashref)
290 Base code to recursively merge two hashes together with right-hand precedence.
295 my ( $lefthash, $righthash ) = @_;
297 return $lefthash unless defined $righthash;
299 my %merged = %$lefthash;
300 for my $key ( keys %$righthash ) {
301 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
302 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
303 if( $right_ref and $left_ref ) {
304 $merged{ $key } = merge_hashes(
305 $lefthash->{ $key }, $righthash->{ $key }
309 $merged{ $key } = $righthash->{ $key };
316 =head2 env_value($class, $key)
318 Checks for and returns an environment value. For instance, if $key is
319 'home', then this method will check for and return the first value it finds,
320 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
325 my ( $class, $key ) = @_;
328 my @prefixes = ( class2env($class), 'CATALYST' );
330 for my $prefix (@prefixes) {
331 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
341 Try to guess terminal width to use with formatting of debug output
343 All you need to get this work, is:
345 1) Install Term::Size::Any, or
347 2) Export $COLUMNS from your shell.
349 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
350 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
351 that 'env' now lists COLUMNS.)
353 As last resort, default value of 80 chars will be used.
360 return $_term_width if $_term_width;
364 my ($columns, $rows) = Term::Size::Any::chars;
369 $width = $ENV{COLUMNS}
370 if exists($ENV{COLUMNS})
371 && $ENV{COLUMNS} =~ m/^\d+$/;
374 $width = 80 unless ($width && $width >= 80);
375 return $_term_width = $width;
380 Catalyst Contributors, see Catalyst.pm
384 This program is free software, you can redistribute it and/or modify it under
385 the same terms as Perl itself.