1 package Catalyst::Utils;
4 use Catalyst::Exception;
14 Catalyst::Utils - The Catalyst Utils
24 =head2 appprefix($class)
26 MyApp::Foo becomes myapp_foo
37 =head2 class2appclass($class);
39 MyApp::Controller::Foo::Bar becomes MyApp
40 My::App::Controller::Foo::Bar becomes My::App
45 my $class = shift || '';
47 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
53 =head2 class2classprefix($class);
55 MyApp::Controller::Foo::Bar becomes MyApp::Controller
56 My::App::Controller::Foo::Bar becomes My::App::Controller
60 sub class2classprefix {
61 my $class = shift || '';
63 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
69 =head2 class2classsuffix($class);
71 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
75 sub class2classsuffix {
76 my $class = shift || '';
77 my $prefix = class2appclass($class) || '';
78 $class =~ s/$prefix\:://;
82 =head2 class2env($class);
84 Returns the environment name for class.
87 My::App becomes MY_APP
92 my $class = shift || '';
97 =head2 class2prefix( $class, $case );
99 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
101 My::App::Controller::Foo::Bar becomes foo/bar
106 my $class = shift || '';
107 my $case = shift || 0;
109 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
110 $prefix = $case ? $2 : lc $2;
111 $prefix =~ s{::}{/}g;
116 =head2 class2tempdir( $class [, $create ] );
118 Returns a tempdir for a class. If create is true it will try to create the path.
120 My::App becomes /tmp/my/app
121 My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
126 my $class = shift || '';
127 my $create = shift || 0;
128 my @parts = split '::', lc $class;
130 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
132 if ( $create && !-e $tmpdir ) {
134 eval { $tmpdir->mkpath };
137 Catalyst::Exception->throw(
138 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
142 return $tmpdir->stringify;
147 Returns home directory for given class.
154 # make an $INC{ $key } style string from the class name
155 (my $file = "$class.pm") =~ s{::}{/}g;
157 if ( my $inc_entry = $INC{$file} ) {
159 # look for an uninstalled Catalyst app
161 # find the @INC entry in which $file was found
162 (my $path = $inc_entry) =~ s/$file$//;
163 my $home = dir($path)->absolute->cleanup;
165 # pop off /lib and /blib if they're there
166 $home = $home->parent while $home =~ /b?lib$/;
168 # only return the dir if it has a Makefile.PL or Build.PL
169 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
171 # clean up relative path:
172 # MyApp/script/.. -> MyApp
175 my @dir_list = $home->dir_list();
176 while (($dir = pop(@dir_list)) && $dir eq '..') {
177 $home = dir($home)->parent->parent;
180 return $home->stringify;
185 # look for an installed Catalyst app
187 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
188 ( my $path = $inc_entry) =~ s/\.pm$//;
189 my $home = dir($path)->absolute->cleanup;
191 # return if if it's a valid directory
192 return $home->stringify if -d $home;
200 =head2 prefix($class, $name);
202 Returns a prefixed action.
204 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
209 my ( $class, $name ) = @_;
210 my $prefix = &class2prefix($class);
211 $name = "$prefix/$name" if $prefix;
217 Returns an L<HTTP::Request> object for a uri.
223 unless ( ref $request ) {
224 if ( $request =~ m/^http/i ) {
225 $request = URI->new($request);
228 $request = URI->new( 'http://localhost' . $request );
231 unless ( ref $request eq 'HTTP::Request' ) {
232 $request = HTTP::Request->new( 'GET', $request );
237 =head2 ensure_class_loaded($class_name, \%opts)
239 Loads the class unless it already has been loaded.
241 If $opts{ignore_loaded} is true always tries the require whether the package
242 already exists or not. Only pass this if you're either (a) sure you know the
243 file exists on disk or (b) have code to catch the file not found exception
244 that will result if it doesn't.
248 sub ensure_class_loaded {
252 croak "Malformed class Name $class"
253 if $class =~ m/(?:\b\:\b|\:{3,})/;
255 croak "Malformed class Name $class"
256 if $class =~ m/[^\w:]/;
258 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
259 if $class =~ m/\.pm$/;
261 return if !$opts->{ ignore_loaded }
262 && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again
264 # this hack is so we don't overwrite $@ if the load did not generate an error
268 my $file = $class . '.pm';
270 eval { CORE::require($file) };
274 die $error if $error;
275 die "require $class was successful but the package is not defined"
276 unless Class::Inspector->loaded($class);
281 =head2 merge_hashes($hashref, $hashref)
283 Base code to recursively merge two hashes together with right-hand precedence.
288 my ( $lefthash, $righthash ) = @_;
290 return $lefthash unless defined $righthash;
292 my %merged = %$lefthash;
293 for my $key ( keys %$righthash ) {
294 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
295 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
296 if( $right_ref and $left_ref ) {
297 $merged{ $key } = merge_hashes(
298 $lefthash->{ $key }, $righthash->{ $key }
302 $merged{ $key } = $righthash->{ $key };
309 =head2 env_value($class, $key)
311 Checks for and returns an environment value. For instance, if $key is
312 'home', then this method will check for and return the first value it finds,
313 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
318 my ( $class, $key ) = @_;
321 my @prefixes = ( class2env($class), 'CATALYST' );
323 for my $prefix (@prefixes) {
324 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
334 Sebastian Riedel, C<sri@cpan.org>
335 Yuval Kogman, C<nothingmuch@woobling.org>
339 This program is free software, you can redistribute it and/or modify it under
340 the same terms as Perl itself.