1 package Catalyst::Utils;
4 use Catalyst::Exception;
12 use String::RewritePrefix;
18 Catalyst::Utils - The Catalyst Utils
30 =head2 appprefix($class)
32 MyApp::Foo becomes myapp_foo
43 =head2 class2appclass($class);
45 MyApp::Controller::Foo::Bar becomes MyApp
46 My::App::Controller::Foo::Bar becomes My::App
51 my $class = shift || '';
53 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
59 =head2 class2classprefix($class);
61 MyApp::Controller::Foo::Bar becomes MyApp::Controller
62 My::App::Controller::Foo::Bar becomes My::App::Controller
66 sub class2classprefix {
67 my $class = shift || '';
69 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
75 =head2 class2classsuffix($class);
77 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
81 sub class2classsuffix {
82 my $class = shift || '';
83 my $prefix = class2appclass($class) || '';
84 $class =~ s/$prefix\:://;
88 =head2 class2env($class);
90 Returns the environment name for class.
93 My::App becomes MY_APP
98 my $class = shift || '';
103 =head2 class2prefix( $class, $case );
105 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
107 My::App::Controller::Foo::Bar becomes foo/bar
112 my $class = shift || '';
113 my $case = shift || 0;
115 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
116 $prefix = $case ? $2 : lc $2;
117 $prefix =~ s{::}{/}g;
122 =head2 class2tempdir( $class [, $create ] );
124 Returns a tempdir for a class. If create is true it will try to create the path.
126 My::App becomes /tmp/my/app
127 My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar
132 my $class = shift || '';
133 my $create = shift || 0;
134 my @parts = split '::', lc $class;
136 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
138 if ( $create && !-e $tmpdir ) {
140 eval { $tmpdir->mkpath };
143 Catalyst::Exception->throw(
144 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
148 return $tmpdir->stringify;
153 Returns home directory for given class.
160 # make an $INC{ $key } style string from the class name
161 (my $file = "$class.pm") =~ s{::}{/}g;
163 if ( my $inc_entry = $INC{$file} ) {
165 # look for an uninstalled Catalyst app
167 # find the @INC entry in which $file was found
168 (my $path = $inc_entry) =~ s/$file$//;
169 $path ||= cwd() if !defined $path || !length $path;
170 my $home = dir($path)->absolute->cleanup;
172 # pop off /lib and /blib if they're there
173 $home = $home->parent while $home =~ /b?lib$/;
175 # only return the dir if it has a Makefile.PL or Build.PL or dist.ini
176 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")
177 or -f $home->file("dist.ini")) {
179 # clean up relative path:
180 # MyApp/script/.. -> MyApp
183 my @dir_list = $home->dir_list();
184 while (($dir = pop(@dir_list)) && $dir eq '..') {
185 $home = dir($home)->parent->parent;
188 return $home->stringify;
193 # look for an installed Catalyst app
195 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
196 ( my $path = $inc_entry) =~ s/\.pm$//;
197 my $home = dir($path)->absolute->cleanup;
199 # return if if it's a valid directory
200 return $home->stringify if -d $home;
208 =head2 prefix($class, $name);
210 Returns a prefixed action.
212 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
217 my ( $class, $name ) = @_;
218 my $prefix = &class2prefix($class);
219 $name = "$prefix/$name" if $prefix;
225 Returns an L<HTTP::Request> object for a uri.
231 unless ( ref $request ) {
232 if ( $request =~ m/^http/i ) {
233 $request = URI->new($request);
236 $request = URI->new( 'http://localhost' . $request );
239 unless ( ref $request eq 'HTTP::Request' ) {
240 $request = HTTP::Request->new( 'GET', $request );
245 =head2 ensure_class_loaded($class_name, \%opts)
247 Loads the class unless it already has been loaded.
249 If $opts{ignore_loaded} is true always tries the require whether the package
250 already exists or not. Only pass this if you're either (a) sure you know the
251 file exists on disk or (b) have code to catch the file not found exception
252 that will result if it doesn't.
256 sub ensure_class_loaded {
260 croak "Malformed class Name $class"
261 if $class =~ m/(?:\b\:\b|\:{3,})/;
263 croak "Malformed class Name $class"
264 if $class =~ m/[^\w:]/;
266 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
267 if $class =~ m/\.pm$/;
269 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
270 # if it already has symbol table entries. This is to support things like Schema::Loader, which
271 # part-generate classes in memory, but then also load some of their contents from disk.
272 return if !$opts->{ ignore_loaded }
273 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
275 # this hack is so we don't overwrite $@ if the load did not generate an error
279 my $file = $class . '.pm';
281 eval { CORE::require($file) };
285 die $error if $error;
287 warn "require $class was successful but the package is not defined."
288 unless Class::MOP::is_class_loaded($class);
293 =head2 merge_hashes($hashref, $hashref)
295 Base code to recursively merge two hashes together with right-hand precedence.
300 my ( $lefthash, $righthash ) = @_;
302 return $lefthash unless defined $righthash;
304 my %merged = %$lefthash;
305 for my $key ( keys %$righthash ) {
306 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
307 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
308 if( $right_ref and $left_ref ) {
309 $merged{ $key } = merge_hashes(
310 $lefthash->{ $key }, $righthash->{ $key }
314 $merged{ $key } = $righthash->{ $key };
321 =head2 env_value($class, $key)
323 Checks for and returns an environment value. For instance, if $key is
324 'home', then this method will check for and return the first value it finds,
325 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
330 my ( $class, $key ) = @_;
333 my @prefixes = ( class2env($class), 'CATALYST' );
335 for my $prefix (@prefixes) {
336 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
346 Try to guess terminal width to use with formatting of debug output
348 All you need to get this work, is:
350 1) Install Term::Size::Any, or
352 2) Export $COLUMNS from your shell.
354 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
355 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
356 that 'env' now lists COLUMNS.)
358 As last resort, default value of 80 chars will be used.
365 return $_term_width if $_term_width;
369 my ($columns, $rows) = Term::Size::Any::chars;
374 $width = $ENV{COLUMNS}
375 if exists($ENV{COLUMNS})
376 && $ENV{COLUMNS} =~ m/^\d+$/;
379 $width = 80 unless ($width && $width >= 80);
380 return $_term_width = $width;
384 =head2 resolve_namespace
386 Method which adds the namespace for plugins and actions.
388 __PACKAGE__->setup(qw(MyPlugin));
390 # will load Catalyst::Plugin::MyPlugin
395 sub resolve_namespace {
396 my $appnamespace = shift;
397 my $namespace = shift;
399 return String::RewritePrefix->rewrite({
400 q[] => qq[${namespace}::],
402 (defined $appnamespace
403 ? (q[~] => qq[${appnamespace}::])
412 Catalyst Contributors, see Catalyst.pm
416 This library is free software. You can redistribute it and/or modify it under
417 the same terms as Perl itself.