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 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 };
142 # don't load Catalyst::Exception as a BEGIN in Utils,
143 # because Utils often gets loaded before MyApp.pm, and if
144 # Catalyst::Exception is loaded before MyApp.pm, it does
146 # $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in
148 require Catalyst::Exception;
149 Catalyst::Exception->throw(
150 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
154 return $tmpdir->stringify;
159 Returns home directory for given class.
166 # make an $INC{ $key } style string from the class name
167 (my $file = "$class.pm") =~ s{::}{/}g;
169 if ( my $inc_entry = $INC{$file} ) {
171 # look for an uninstalled Catalyst app
173 # find the @INC entry in which $file was found
174 (my $path = $inc_entry) =~ s/$file$//;
175 $path ||= cwd() if !defined $path || !length $path;
176 my $home = dir($path)->absolute->cleanup;
178 # pop off /lib and /blib if they're there
179 $home = $home->parent while $home =~ /b?lib$/;
181 # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
182 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")
183 or -f $home->file("dist.ini")) {
185 # clean up relative path:
186 # MyApp/script/.. -> MyApp
189 my @dir_list = $home->dir_list();
190 while (($dir = pop(@dir_list)) && $dir eq '..') {
191 $home = dir($home)->parent->parent;
194 return $home->stringify;
199 # look for an installed Catalyst app
201 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
202 ( my $path = $inc_entry) =~ s/\.pm$//;
203 my $home = dir($path)->absolute->cleanup;
205 # return if if it's a valid directory
206 return $home->stringify if -d $home;
214 =head2 prefix($class, $name);
216 Returns a prefixed action.
218 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
223 my ( $class, $name ) = @_;
224 my $prefix = &class2prefix($class);
225 $name = "$prefix/$name" if $prefix;
231 Returns an L<HTTP::Request> object for a uri.
237 unless ( ref $request ) {
238 if ( $request =~ m/^http/i ) {
239 $request = URI->new($request);
242 $request = URI->new( 'http://localhost' . $request );
245 unless ( ref $request eq 'HTTP::Request' ) {
246 $request = HTTP::Request->new( 'GET', $request );
251 =head2 ensure_class_loaded($class_name, \%opts)
253 Loads the class unless it already has been loaded.
255 If $opts{ignore_loaded} is true always tries the require whether the package
256 already exists or not. Only pass this if you're either (a) sure you know the
257 file exists on disk or (b) have code to catch the file not found exception
258 that will result if it doesn't.
262 sub ensure_class_loaded {
266 croak "Malformed class Name $class"
267 if $class =~ m/(?:\b\:\b|\:{3,})/;
269 croak "Malformed class Name $class"
270 if $class =~ m/[^\w:]/;
272 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
273 if $class =~ m/\.pm$/;
275 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
276 # if it already has symbol table entries. This is to support things like Schema::Loader, which
277 # part-generate classes in memory, but then also load some of their contents from disk.
278 return if !$opts->{ ignore_loaded }
279 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
281 # this hack is so we don't overwrite $@ if the load did not generate an error
285 my $file = $class . '.pm';
287 eval { CORE::require($file) };
291 die $error if $error;
293 warn "require $class was successful but the package is not defined."
294 unless Class::MOP::is_class_loaded($class);
299 =head2 merge_hashes($hashref, $hashref)
301 Base code to recursively merge two hashes together with right-hand precedence.
306 my ( $lefthash, $righthash ) = @_;
308 return $lefthash unless defined $righthash;
310 my %merged = %$lefthash;
311 for my $key ( keys %$righthash ) {
312 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
313 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
314 if( $right_ref and $left_ref ) {
315 $merged{ $key } = merge_hashes(
316 $lefthash->{ $key }, $righthash->{ $key }
320 $merged{ $key } = $righthash->{ $key };
327 =head2 env_value($class, $key)
329 Checks for and returns an environment value. For instance, if $key is
330 'home', then this method will check for and return the first value it finds,
331 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
336 my ( $class, $key ) = @_;
339 my @prefixes = ( class2env($class), 'CATALYST' );
341 for my $prefix (@prefixes) {
342 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
352 Try to guess terminal width to use with formatting of debug output
354 All you need to get this work, is:
356 1) Install Term::Size::Any, or
358 2) Export $COLUMNS from your shell.
360 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
361 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
362 that 'env' now lists COLUMNS.)
364 As last resort, default value of 80 chars will be used.
371 return $_term_width if $_term_width;
375 my ($columns, $rows) = Term::Size::Any::chars;
380 $width = $ENV{COLUMNS}
381 if exists($ENV{COLUMNS})
382 && $ENV{COLUMNS} =~ m/^\d+$/;
385 $width = 80 unless ($width && $width >= 80);
386 return $_term_width = $width;
390 =head2 resolve_namespace
392 Method which adds the namespace for plugins and actions.
394 __PACKAGE__->setup(qw(MyPlugin));
396 # will load Catalyst::Plugin::MyPlugin
401 sub resolve_namespace {
402 my $appnamespace = shift;
403 my $namespace = shift;
405 return String::RewritePrefix->rewrite({
406 q[] => qq[${namespace}::],
408 (defined $appnamespace
409 ? (q[~] => qq[${appnamespace}::])
418 Catalyst Contributors, see Catalyst.pm
422 This library is free software. You can redistribute it and/or modify it under
423 the same terms as Perl itself.