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 $path ||= cwd() if !defined $path || !length $path;
164 my $home = dir($path)->absolute->cleanup;
166 # pop off /lib and /blib if they're there
167 $home = $home->parent while $home =~ /b?lib$/;
169 # only return the dir if it has a Makefile.PL or Build.PL
170 if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
172 # clean up relative path:
173 # MyApp/script/.. -> MyApp
176 my @dir_list = $home->dir_list();
177 while (($dir = pop(@dir_list)) && $dir eq '..') {
178 $home = dir($home)->parent->parent;
181 return $home->stringify;
186 # look for an installed Catalyst app
188 # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
189 ( my $path = $inc_entry) =~ s/\.pm$//;
190 my $home = dir($path)->absolute->cleanup;
192 # return if if it's a valid directory
193 return $home->stringify if -d $home;
201 =head2 prefix($class, $name);
203 Returns a prefixed action.
205 MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
210 my ( $class, $name ) = @_;
211 my $prefix = &class2prefix($class);
212 $name = "$prefix/$name" if $prefix;
218 Returns an L<HTTP::Request> object for a uri.
224 unless ( ref $request ) {
225 if ( $request =~ m/^http/i ) {
226 $request = URI->new($request);
229 $request = URI->new( 'http://localhost' . $request );
232 unless ( ref $request eq 'HTTP::Request' ) {
233 $request = HTTP::Request->new( 'GET', $request );
238 =head2 ensure_class_loaded($class_name, \%opts)
240 Loads the class unless it already has been loaded.
242 If $opts{ignore_loaded} is true always tries the require whether the package
243 already exists or not. Only pass this if you're either (a) sure you know the
244 file exists on disk or (b) have code to catch the file not found exception
245 that will result if it doesn't.
249 sub ensure_class_loaded {
253 croak "Malformed class Name $class"
254 if $class =~ m/(?:\b\:\b|\:{3,})/;
256 croak "Malformed class Name $class"
257 if $class =~ m/[^\w:]/;
259 croak "ensure_class_loaded should be given a classname, not a filename ($class)"
260 if $class =~ m/\.pm$/;
262 # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
263 # if it already has symbol table entries. This is to support things like Schema::Loader, which
264 # part-generate classes in memory, but then also load some of their contents from disk.
265 return if !$opts->{ ignore_loaded }
266 && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
268 # FIXME - as soon as Class::MOP 0.67 + 1 is released Class::MOP::load_class($class) can be used instead
270 # this hack is so we don't overwrite $@ if the load did not generate an error
274 my $file = $class . '.pm';
276 eval { CORE::require($file) };
280 die $error if $error;
282 warn "require $class was successful but the package is not defined."
283 unless Class::MOP::is_class_loaded($class);
288 =head2 merge_hashes($hashref, $hashref)
290 Base code to recursively merge two hashes together with right-hand precedence.
295 my ( $lefthash, $righthash ) = @_;
297 return $lefthash unless defined $righthash;
299 my %merged = %$lefthash;
300 for my $key ( keys %$righthash ) {
301 my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
302 my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
303 if( $right_ref and $left_ref ) {
304 $merged{ $key } = merge_hashes(
305 $lefthash->{ $key }, $righthash->{ $key }
309 $merged{ $key } = $righthash->{ $key };
316 =head2 env_value($class, $key)
318 Checks for and returns an environment value. For instance, if $key is
319 'home', then this method will check for and return the first value it finds,
320 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
325 my ( $class, $key ) = @_;
328 my @prefixes = ( class2env($class), 'CATALYST' );
330 for my $prefix (@prefixes) {
331 if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
341 Catalyst Contributors, see Catalyst.pm
345 This program is free software, you can redistribute it and/or modify it under
346 the same terms as Perl itself.