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.
161 =head2 dist_indicator_file_list
163 Returns a list of files which can be tested to check if you're inside
168 sub dist_indicator_file_list {
169 qw{Makefile.PL Build.PL dist.ini};
175 # make an $INC{ $key } style string from the class name
176 (my $file = "$class.pm") =~ s{::}{/}g;
178 if ( my $inc_entry = $INC{$file} ) {
180 # look for an uninstalled Catalyst app
182 # find the @INC entry in which $file was found
183 (my $path = $inc_entry) =~ s/$file$//;
184 $path ||= cwd() if !defined $path || !length $path;
185 my $home = dir($path)->absolute->cleanup;
187 # pop off /lib and /blib if they're there
188 $home = $home->parent while $home =~ /b?lib$/;
190 # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
191 if (grep { -f $home->file($_) } dist_indicator_file_list()) {
192 # clean up relative path:
193 # MyApp/script/.. -> MyApp
196 my @dir_list = $home->dir_list();
197 while (($dir = pop(@dir_list)) && $dir eq '..') {
198 $home = dir($home)->parent->parent;
201 return $home->stringify;
206 # look for an installed Catalyst app
208 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
209 ( my $path = $inc_entry) =~ s/\.pm$//;
210 my $home = dir($path)->absolute->cleanup;
212 # return if if it's a valid directory
213 return $home->stringify if -d $home;
221 =head2 prefix($class, $name);
223 Returns a prefixed action.
225 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
230 my ( $class, $name ) = @_;
231 my $prefix = &class2prefix($class);
232 $name = "$prefix/$name" if $prefix;
238 Returns an L<HTTP::Request> object for a uri.
244 unless ( ref $request ) {
245 if ( $request =~ m/^http/i ) {
246 $request = URI->new($request);
249 $request = URI->new( 'http://localhost' . $request );
252 unless ( ref $request eq 'HTTP::Request' ) {
253 $request = HTTP::Request->new( 'GET', $request );
258 =head2 ensure_class_loaded($class_name, \%opts)
260 Loads the class unless it already has been loaded.
262 If $opts{ignore_loaded} is true always tries the require whether the package
263 already exists or not. Only pass this if you're either (a) sure you know the
264 file exists on disk or (b) have code to catch the file not found exception
265 that will result if it doesn't.
269 sub ensure_class_loaded {
273 croak "Malformed class Name $class"
274 if $class =~ m/(?:\b\:\b|\:{3,})/;
276 croak "Malformed class Name $class"
277 if $class =~ m/[^\w:]/;
279 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
280 if $class =~ m/\.pm$/;
282 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
283 # if it already has symbol table entries. This is to support things like Schema::Loader, which
284 # part-generate classes in memory, but then also load some of their contents from disk.
285 return if !$opts->{ ignore_loaded }
286 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
288 # this hack is so we don't overwrite $@ if the load did not generate an error
292 my $file = $class . '.pm';
294 eval { CORE::require($file) };
298 die $error if $error;
300 warn "require $class was successful but the package is not defined."
301 unless Class::MOP::is_class_loaded($class);
306 =head2 merge_hashes($hashref, $hashref)
308 Base code to recursively merge two hashes together with right-hand precedence.
313 my ( $lefthash, $righthash ) = @_;
315 return $lefthash unless defined $righthash;
317 my %merged = %$lefthash;
318 for my $key ( keys %$righthash ) {
319 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
320 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
321 if( $right_ref and $left_ref ) {
322 $merged{ $key } = merge_hashes(
323 $lefthash->{ $key }, $righthash->{ $key }
327 $merged{ $key } = $righthash->{ $key };
334 =head2 env_value($class, $key)
336 Checks for and returns an environment value. For instance, if $key is
337 'home', then this method will check for and return the first value it finds,
338 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
343 my ( $class, $key ) = @_;
346 my @prefixes = ( class2env($class), 'CATALYST' );
348 for my $prefix (@prefixes) {
349 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
359 Try to guess terminal width to use with formatting of debug output
361 All you need to get this work, is:
363 1) Install Term::Size::Any, or
365 2) Export $COLUMNS from your shell.
367 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
368 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
369 that 'env' now lists COLUMNS.)
371 As last resort, default value of 80 chars will be used.
378 return $_term_width if $_term_width;
382 my ($columns, $rows) = Term::Size::Any::chars;
387 $width = $ENV{COLUMNS}
388 if exists($ENV{COLUMNS})
389 && $ENV{COLUMNS} =~ m/^\d+$/;
392 $width = 80 unless ($width && $width >= 80);
393 return $_term_width = $width;
397 =head2 resolve_namespace
399 Method which adds the namespace for plugins and actions.
401 __PACKAGE__->setup(qw(MyPlugin));
403 # will load Catalyst::Plugin::MyPlugin
408 sub resolve_namespace {
409 my $appnamespace = shift;
410 my $namespace = shift;
412 return String::RewritePrefix->rewrite({
413 q[] => qq[${namespace}::],
415 (defined $appnamespace
416 ? (q[~] => qq[${appnamespace}::])
425 Catalyst Contributors, see Catalyst.pm
429 This library is free software. You can redistribute it and/or modify it under
430 the same terms as Perl itself.