lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use Catalyst::Exception;
   5 use File::Spec;
   6 use HTTP::Request;
   7 use Path::Class;
   8 use URI;
   9 use Carp qw/croak/;
  10 use Cwd;
  11
  12 =head1 NAME
  13
  14 Catalyst::Utils - The Catalyst Utils
  15
  16 =head1 SYNOPSIS
  17
  18 See L<Catalyst>.
  19
  20 =head1 DESCRIPTION
  21
  22 Catalyst Utilities.
  23
  24 =head1 METHODS
  25
  26 =head2 appprefix($class)
  27
  28     MyApp::Foo becomes myapp_foo
  29
  30 =cut
  31
  32 sub appprefix {
  33     my $class = shift;
  34     $class =~ s/::/_/g;
  35     $class = lc($class);
  36     return $class;
  37 }
  38
  39 =head2 class2appclass($class);
  40
  41     MyApp::Controller::Foo::Bar becomes MyApp
  42     My::App::Controller::Foo::Bar becomes My::App
  43
  44 =cut
  45
  46 sub class2appclass {
  47     my $class = shift || '';
  48     my $appname = '';
  49     if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) {
  50         $appname = $1;
  51     }
  52     return $appname;
  53 }
  54
  55 =head2 class2classprefix($class);
  56
  57     MyApp::Controller::Foo::Bar becomes MyApp::Controller
  58     My::App::Controller::Foo::Bar becomes My::App::Controller
  59
  60 =cut
  61
  62 sub class2classprefix {
  63     my $class = shift || '';
  64     my $prefix;
  65     if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) {
  66         $prefix = $1;
  67     }
  68     return $prefix;
  69 }
  70
  71 =head2 class2classsuffix($class);
  72
  73     MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar
  74
  75 =cut
  76
  77 sub class2classsuffix {
  78     my $class = shift || '';
  79     my $prefix = class2appclass($class) || '';
  80     $class =~ s/$prefix\:://;
  81     return $class;
  82 }
  83
  84 =head2 class2env($class);
  85
  86 Returns the environment name for class.
  87
  88     MyApp becomes MYAPP
  89     My::App becomes MY_APP
  90
  91 =cut
  92
  93 sub class2env {
  94     my $class = shift || '';
  95     $class =~ s/::/_/g;
  96     return uc($class);
  97 }
  98
  99 =head2 class2prefix( $class, $case );
 100
 101 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
 102
 103     My::App::Controller::Foo::Bar becomes foo/bar
 104
 105 =cut
 106
 107 sub class2prefix {
 108     my $class = shift || '';
 109     my $case  = shift || 0;
 110     my $prefix;
 111     if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) {
 112         $prefix = $case ? $2 : lc $2;
 113         $prefix =~ s{::}{/}g;
 114     }
 115     return $prefix;
 116 }
 117
 118 =head2 class2tempdir( $class [, $create ] );
 119
 120 Returns a tempdir for a class. If create is true it will try to create the path.
 121
 122     My::App becomes /tmp/my/app
 123     My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
 124
 125 =cut
 126
 127 sub class2tempdir {
 128     my $class  = shift || '';
 129     my $create = shift || 0;
 130     my @parts = split '::', lc $class;
 131
 132     my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
 133
 134     if ( $create && !-e $tmpdir ) {
 135
 136         eval { $tmpdir->mkpath };
 137
 138         if ($@) {
 139             Catalyst::Exception->throw(
 140                 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
 141         }
 142     }
 143
 144     return $tmpdir->stringify;
 145 }
 146
 147 =head2 home($class)
 148
 149 Returns home directory for given class.
 150
 151 =cut
 152
 153 sub home {
 154     my $class = shift;
 155
 156     # make an $INC{ $key } style string from the class name
 157     (my $file = "$class.pm") =~ s{::}{/}g;
 158
 159     if ( my $inc_entry = $INC{$file} ) {
 160         {
 161             # look for an uninstalled Catalyst app
 162
 163             # find the @INC entry in which $file was found
 164             (my $path = $inc_entry) =~ s/$file$//;
 165             $path ||= cwd() if !defined $path || !length $path;
 166             my $home = dir($path)->absolute->cleanup;
 167
 168             # pop off /lib and /blib if they're there
 169             $home = $home->parent while $home =~ /b?lib$/;
 170
 171             # only return the dir if it has a Makefile.PL or Build.PL
 172             if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
 173
 174                 # clean up relative path:
 175                 # MyApp/script/.. -> MyApp
 176
 177                 my $dir;
 178                 my @dir_list = $home->dir_list();
 179                 while (($dir = pop(@dir_list)) && $dir eq '..') {
 180                     $home = dir($home)->parent->parent;
 181                 }
 182
 183                 return $home->stringify;
 184             }
 185         }
 186
 187         {
 188             # look for an installed Catalyst app
 189
 190             # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
 191             ( my $path = $inc_entry) =~ s/\.pm$//;
 192             my $home = dir($path)->absolute->cleanup;
 193
 194             # return if if it's a valid directory
 195             return $home->stringify if -d $home;
 196         }
 197     }
 198
 199     # we found nothing
 200     return 0;
 201 }
 202
 203 =head2 prefix($class, $name);
 204
 205 Returns a prefixed action.
 206
 207     MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
 208
 209 =cut
 210
 211 sub prefix {
 212     my ( $class, $name ) = @_;
 213     my $prefix = &class2prefix($class);
 214     $name = "$prefix/$name" if $prefix;
 215     return $name;
 216 }
 217
 218 =head2 request($uri)
 219
 220 Returns an L<HTTP::Request> object for a uri.
 221
 222 =cut
 223
 224 sub request {
 225     my $request = shift;
 226     unless ( ref $request ) {
 227         if ( $request =~ m/^http/i ) {
 228             $request = URI->new($request);
 229         }
 230         else {
 231             $request = URI->new( 'http://localhost' . $request );
 232         }
 233     }
 234     unless ( ref $request eq 'HTTP::Request' ) {
 235         $request = HTTP::Request->new( 'GET', $request );
 236     }
 237     return $request;
 238 }
 239
 240 =head2 ensure_class_loaded($class_name, \%opts)
 241
 242 Loads the class unless it already has been loaded.
 243
 244 If $opts{ignore_loaded} is true always tries the require whether the package
 245 already exists or not. Only pass this if you're either (a) sure you know the
 246 file exists on disk or (b) have code to catch the file not found exception
 247 that will result if it doesn't.
 248
 249 =cut
 250
 251 sub ensure_class_loaded {
 252     my $class = shift;
 253     my $opts  = shift;
 254
 255     croak "Malformed class Name $class"
 256         if $class =~ m/(?:\b\:\b|\:{3,})/;
 257
 258     croak "Malformed class Name $class"
 259         if $class =~ m/[^\w:]/;
 260
 261     croak "ensure_class_loaded should be given a classname, not a filename ($class)"
 262         if $class =~ m/\.pm$/;
 263
 264     # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
 265     # if it already has symbol table entries. This is to support things like Schema::Loader, which
 266     # part-generate classes in memory, but then also load some of their contents from disk.
 267     return if !$opts->{ ignore_loaded }
 268         && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
 269
 270     # this hack is so we don't overwrite $@ if the load did not generate an error
 271     my $error;
 272     {
 273         local $@;
 274         my $file = $class . '.pm';
 275         $file =~ s{::}{/}g;
 276         eval { CORE::require($file) };
 277         $error = $@;
 278     }
 279
 280     die $error if $error;
 281
 282     warn "require $class was successful but the package is not defined."
 283         unless Class::MOP::is_class_loaded($class);
 284
 285     return 1;
 286 }
 287
 288 =head2 merge_hashes($hashref, $hashref)
 289
 290 Base code to recursively merge two hashes together with right-hand precedence.
 291
 292 =cut
 293
 294 sub merge_hashes {
 295     my ( $lefthash, $righthash ) = @_;
 296
 297     return $lefthash unless defined $righthash;
 298
 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 }
 306             );
 307         }
 308         else {
 309             $merged{ $key } = $righthash->{ $key };
 310         }
 311     }
 312
 313     return \%merged;
 314 }
 315
 316 =head2 env_value($class, $key)
 317
 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}.
 321
 322 =cut
 323
 324 sub env_value {
 325     my ( $class, $key ) = @_;
 326
 327     $key = uc($key);
 328     my @prefixes = ( class2env($class), 'CATALYST' );
 329
 330     for my $prefix (@prefixes) {
 331         if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
 332             return $value;
 333         }
 334     }
 335
 336     return;
 337 }
 338
 339 =head2 term_width
 340
 341 Try to guess terminal width to use with formatting of debug output
 342
 343 All you need to get this work, is:
 344
 345 1) Install Term::Size::Any, or
 346
 347 2) Export $COLUMNS from your shell.
 348
 349 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
 350 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
 351 that 'env' now lists COLUMNS.)
 352
 353 As last resort, default value of 80 chars will be used.
 354
 355 =cut
 356
 357 my $_term_width;
 358
 359 sub term_width {
 360     return $_term_width if $_term_width;
 361
 362     my $width = eval '
 363         use Term::Size::Any;
 364         my ($columns, $rows) = Term::Size::Any::chars;
 365         return $columns;
 366     ';
 367
 368     if ($@) {
 369         $width = $ENV{COLUMNS}
 370             if exists($ENV{COLUMNS})
 371             && $ENV{COLUMNS} =~ m/^\d+$/;
 372     }
 373
 374     $width = 80 unless ($width && $width >= 80);
 375     return $_term_width = $width;
 376 }
 377
 378 =head1 AUTHORS
 379
 380 Catalyst Contributors, see Catalyst.pm
 381
 382 =head1 COPYRIGHT
 383
 384 This program is free software, you can redistribute it and/or modify it under
 385 the same terms as Perl itself.
 386
 387 =cut
 388
 389 1;