1 package Catalyst::Utils;
4 use Catalyst::Exception;
15 Catalyst::Utils - The Catalyst Utils
25 =head2 appprefix($class)
27 MyApp::Foo becomes myapp_foo
38 =head2 class2appclass($class);
40 MyApp::Controller::Foo::Bar becomes MyApp
41 My::App::Controller::Foo::Bar becomes My::App
46 my $class = shift || '';
48 if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
54 =head2 class2classprefix($class);
56 MyApp::Controller::Foo::Bar becomes MyApp::Controller
57 My::App::Controller::Foo::Bar becomes My::App::Controller
61 sub class2classprefix {
62 my $class = shift || '';
64 if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
70 =head2 class2classsuffix($class);
72 MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
76 sub class2classsuffix {
77 my $class = shift || '';
78 my $prefix = class2appclass($class) || '';
79 $class =~ s/$prefix\:://;
83 =head2 class2env($class);
85 Returns the environment name for class.
88 My::App becomes MY_APP
93 my $class = shift || '';
98 =head2 class2prefix( $class, $case );
100 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
102 My::App::Controller::Foo::Bar becomes foo/bar
107 my $class = shift || '';
108 my $case = shift || 0;
110 if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
111 $prefix = $case ? $2 : lc $2;
112 $prefix =~ s{::}{/}g;
117 =head2 class2tempdir( $class [, $create ] );
119 Returns a tempdir for a class. If create is true it will try to create the path.
121 My::App becomes /tmp/my/app
122 My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
127 my $class = shift || '';
128 my $create = shift || 0;
129 my @parts = split '::', lc $class;
131 my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
133 if ( $create && !-e $tmpdir ) {
135 eval { $tmpdir->mkpath };
138 Catalyst::Exception->throw(
139 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
143 return $tmpdir->stringify;
148 Returns home directory for given class.
155 # make an $INC{ $key } style string from the class name
156 (my $file = "$class.pm") =~ s{::}{/}g;
158 if ( my $inc_entry = $INC{$file} ) {
160 # look for an uninstalled Catalyst app
162 # find the @INC entry in which $file was found
163 (my $path = $inc_entry) =~ s/$file$//;
164 $path ||= cwd() if !defined $path || !length $path;
165 my $home = dir($path)->absolute->cleanup;
167 # pop off /lib and /blib if they're there
168 $home = $home->parent while $home =~ /b?lib$/;
170 # only return the dir if it has a Makefile.PL or Build.PL
171 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
173 # clean up relative path:
174 # MyApp/script/.. -> MyApp
177 my @dir_list = $home->dir_list();
178 while (($dir = pop(@dir_list)) && $dir eq '..') {
179 $home = dir($home)->parent->parent;
182 return $home->stringify;
187 # look for an installed Catalyst app
189 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
190 ( my $path = $inc_entry) =~ s/\.pm$//;
191 my $home = dir($path)->absolute->cleanup;
193 # return if if it's a valid directory
194 return $home->stringify if -d $home;
202 =head2 prefix($class, $name);
204 Returns a prefixed action.
206 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
211 my ( $class, $name ) = @_;
212 my $prefix = &class2prefix($class);
213 $name = "$prefix/$name" if $prefix;
219 Returns an L<HTTP::Request> object for a uri.
225 unless ( ref $request ) {
226 if ( $request =~ m/^http/i ) {
227 $request = URI->new($request);
230 $request = URI->new( 'http://localhost' . $request );
233 unless ( ref $request eq 'HTTP::Request' ) {
234 $request = HTTP::Request->new( 'GET', $request );
239 =head2 ensure_class_loaded($class_name, \%opts)
241 Loads the class unless it already has been loaded.
243 If $opts{ignore_loaded} is true always tries the require whether the package
244 already exists or not. Only pass this if you're either (a) sure you know the
245 file exists on disk or (b) have code to catch the file not found exception
246 that will result if it doesn't.
250 sub ensure_class_loaded {
254 croak "Malformed class Name $class"
255 if $class =~ m/(?:\b\:\b|\:{3,})/;
257 croak "Malformed class Name $class"
258 if $class =~ m/[^\w:]/;
260 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
261 if $class =~ m/\.pm$/;
263 return if !$opts->{ ignore_loaded }
264 && Class::Inspector->loaded( $class ); # if a symbol entry exists we don't load again
266 # this hack is so we don't overwrite $@ if the load did not generate an error
270 my $file = $class . '.pm';
272 eval { CORE::require($file) };
276 die $error if $error;
277 die "require $class was successful but the package is not defined"
278 unless Class::Inspector->loaded($class);
283 =head2 merge_hashes($hashref, $hashref)
285 Base code to recursively merge two hashes together with right-hand precedence.
290 my ( $lefthash, $righthash ) = @_;
292 return $lefthash unless defined $righthash;
294 my %merged = %$lefthash;
295 for my $key ( keys %$righthash ) {
296 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
297 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
298 if( $right_ref and $left_ref ) {
299 $merged{ $key } = merge_hashes(
300 $lefthash->{ $key }, $righthash->{ $key }
304 $merged{ $key } = $righthash->{ $key };
311 =head2 env_value($class, $key)
313 Checks for and returns an environment value. For instance, if $key is
314 'home', then this method will check for and return the first value it finds,
315 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
320 my ( $class, $key ) = @_;
323 my @prefixes = ( class2env($class), 'CATALYST' );
325 for my $prefix (@prefixes) {
326 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
336 Catalyst Contributors, see Catalyst.pm
340 This program is free software, you can redistribute it and/or modify it under
341 the same terms as Perl itself.