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