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
174 my ($lastdir) = $home->dir_list( -1, 1 );
175 if ( $lastdir eq '..' ) {
176 $home = dir($home)->parent->parent;
179 return $home->stringify;
184 # look for an installed Catalyst app
186 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
187 ( my $path = $inc_entry) =~ s/\.pm$//;
188 my $home = dir($path)->absolute->cleanup;
190 # return if if it's a valid directory
191 return $home->stringify if -d $home;
199 =head2 prefix($class, $name);
201 Returns a prefixed action.
203 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
208 my ( $class, $name ) = @_;
209 my $prefix = &class2prefix($class);
210 $name = "$prefix/$name" if $prefix;
216 Returns an L<HTTP::Request> object for a uri.
222 unless ( ref $request ) {
223 if ( $request =~ m/^http/i ) {
224 $request = URI->new($request);
227 $request = URI->new( 'http://localhost' . $request );
230 unless ( ref $request eq 'HTTP::Request' ) {
231 $request = HTTP::Request->new( 'GET', $request );
236 =head2 ensure_class_loaded($class_name, \%opts)
238 Loads the class unless it already has been loaded.
240 If $opts{ignore_loaded} is true always tries the require whether the package
241 already exists or not. Only pass this if you're either (a) sure you know the
242 file exists on disk or (b) have code to catch the file not found exception
243 that will result if it doesn't.
247 sub ensure_class_loaded {
251 croak "Malformed class Name $class"
252 if $class =~ m/(?:\b\:\b|\:{3,})/;
254 croak "Malformed class Name $class"
255 if $class =~ m/[^\w:]/;
257 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
258 if $class =~ m/\.pm$/;
260 return if !$opts->{ ignore_loaded }
261 && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again
263 # this hack is so we don't overwrite $@ if the load did not generate an error
267 eval "require $class;";
271 die $error if $error;
272 die "require $class was successful but the package is not defined"
273 unless Class::Inspector->loaded($class);
278 =head2 merge_hashes($hashref, $hashref)
280 Base code to recursively merge two hashes together with right-hand precedence.
285 my ( $lefthash, $righthash ) = @_;
287 return $lefthash unless defined $righthash;
289 my %merged = %$lefthash;
290 for my $key ( keys %$righthash ) {
291 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
292 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
293 if( $right_ref and $left_ref ) {
294 $merged{ $key } = merge_hashes(
295 $lefthash->{ $key }, $righthash->{ $key }
299 $merged{ $key } = $righthash->{ $key };
306 =head2 env_value($class, $key)
308 Checks for and returns an environment value. For instance, if $key is
309 'home', then this method will check for and return the first value it finds,
310 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
315 my ( $class, $key ) = @_;
318 my @prefixes = ( class2env($class), 'CATALYST' );
320 for my $prefix (@prefixes) {
321 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
331 Sebastian Riedel, C<sri@cpan.org>
332 Yuval Kogman, C<nothingmuch@woobling.org>
336 This program is free software, you can redistribute it and/or modify it under
337 the same terms as Perl itself.