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::C::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
 176             if (-f $home->file("Makefile.PL") or -f $home->file("Build.PL")) {
 177
 178                 # clean up relative path:
 179                 # MyApp/script/.. -> MyApp
 180
 181                 my $dir;
 182                 my @dir_list = $home->dir_list();
 183                 while (($dir = pop(@dir_list)) && $dir eq '..') {
 184                     $home = dir($home)->parent->parent;
 185                 }
 186
 187                 return $home->stringify;
 188             }
 189         }
 190
 191         {
 192             # look for an installed Catalyst app
 193
 194             # trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ )
 195             ( my $path = $inc_entry) =~ s/\.pm$//;
 196             my $home = dir($path)->absolute->cleanup;
 197
 198             # return if if it's a valid directory
 199             return $home->stringify if -d $home;
 200         }
 201     }
 202
 203     # we found nothing
 204     return 0;
 205 }
 206
 207 =head2 prefix($class, $name);
 208
 209 Returns a prefixed action.
 210
 211     MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada
 212
 213 =cut
 214
 215 sub prefix {
 216     my ( $class, $name ) = @_;
 217     my $prefix = &class2prefix($class);
 218     $name = "$prefix/$name" if $prefix;
 219     return $name;
 220 }
 221
 222 =head2 request($uri)
 223
 224 Returns an L<HTTP::Request> object for a uri.
 225
 226 =cut
 227
 228 sub request {
 229     my $request = shift;
 230     unless ( ref $request ) {
 231         if ( $request =~ m/^http/i ) {
 232             $request = URI->new($request);
 233         }
 234         else {
 235             $request = URI->new( 'http://localhost' . $request );
 236         }
 237     }
 238     unless ( ref $request eq 'HTTP::Request' ) {
 239         $request = HTTP::Request->new( 'GET', $request );
 240     }
 241     return $request;
 242 }
 243
 244 =head2 ensure_class_loaded($class_name, \%opts)
 245
 246 Loads the class unless it already has been loaded.
 247
 248 If $opts{ignore_loaded} is true always tries the require whether the package
 249 already exists or not. Only pass this if you're either (a) sure you know the
 250 file exists on disk or (b) have code to catch the file not found exception
 251 that will result if it doesn't.
 252
 253 =cut
 254
 255 sub ensure_class_loaded {
 256     my $class = shift;
 257     my $opts  = shift;
 258
 259     croak "Malformed class Name $class"
 260         if $class =~ m/(?:\b\:\b|\:{3,})/;
 261
 262     croak "Malformed class Name $class"
 263         if $class =~ m/[^\w:]/;
 264
 265     croak "ensure_class_loaded should be given a classname, not a filename ($class)"
 266         if $class =~ m/\.pm$/;
 267
 268     # $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even
 269     # if it already has symbol table entries. This is to support things like Schema::Loader, which
 270     # part-generate classes in memory, but then also load some of their contents from disk.
 271     return if !$opts->{ ignore_loaded }
 272         && Class::MOP::is_class_loaded($class); # if a symbol entry exists we don't load again
 273
 274     # this hack is so we don't overwrite $@ if the load did not generate an error
 275     my $error;
 276     {
 277         local $@;
 278         my $file = $class . '.pm';
 279         $file =~ s{::}{/}g;
 280         eval { CORE::require($file) };
 281         $error = $@;
 282     }
 283
 284     die $error if $error;
 285
 286     warn "require $class was successful but the package is not defined."
 287         unless Class::MOP::is_class_loaded($class);
 288
 289     return 1;
 290 }
 291
 292 =head2 merge_hashes($hashref, $hashref)
 293
 294 Base code to recursively merge two hashes together with right-hand precedence.
 295
 296 =cut
 297
 298 sub merge_hashes {
 299     my ( $lefthash, $righthash ) = @_;
 300
 301     return $lefthash unless defined $righthash;
 302
 303     my %merged = %$lefthash;
 304     for my $key ( keys %$righthash ) {
 305         my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH';
 306         my $left_ref  = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH';
 307         if( $right_ref and $left_ref ) {
 308             $merged{ $key } = merge_hashes(
 309                 $lefthash->{ $key }, $righthash->{ $key }
 310             );
 311         }
 312         else {
 313             $merged{ $key } = $righthash->{ $key };
 314         }
 315     }
 316
 317     return \%merged;
 318 }
 319
 320 =head2 env_value($class, $key)
 321
 322 Checks for and returns an environment value. For instance, if $key is
 323 'home', then this method will check for and return the first value it finds,
 324 looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}.
 325
 326 =cut
 327
 328 sub env_value {
 329     my ( $class, $key ) = @_;
 330
 331     $key = uc($key);
 332     my @prefixes = ( class2env($class), 'CATALYST' );
 333
 334     for my $prefix (@prefixes) {
 335         if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) {
 336             return $value;
 337         }
 338     }
 339
 340     return;
 341 }
 342
 343 =head2 term_width
 344
 345 Try to guess terminal width to use with formatting of debug output
 346
 347 All you need to get this work, is:
 348
 349 1) Install Term::Size::Any, or
 350
 351 2) Export $COLUMNS from your shell.
 352
 353 (Warning to bash users: 'echo $COLUMNS' may be showing you the bash
 354 variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see
 355 that 'env' now lists COLUMNS.)
 356
 357 As last resort, default value of 80 chars will be used.
 358
 359 =cut
 360
 361 my $_term_width;
 362
 363 sub term_width {
 364     return $_term_width if $_term_width;
 365
 366     my $width = eval '
 367         use Term::Size::Any;
 368         my ($columns, $rows) = Term::Size::Any::chars;
 369         return $columns;
 370     ';
 371
 372     if ($@) {
 373         $width = $ENV{COLUMNS}
 374             if exists($ENV{COLUMNS})
 375             && $ENV{COLUMNS} =~ m/^\d+$/;
 376     }
 377
 378     $width = 80 unless ($width && $width >= 80);
 379     return $_term_width = $width;
 380 }
 381
 382
 383 =head2 resolve_namespace
 384
 385 Method which adds the namespace for plugins and actions.
 386
 387   __PACKAGE__->setup(qw(MyPlugin));
 388
 389   # will load Catalyst::Plugin::MyPlugin
 390
 391 =cut
 392
 393
 394 sub resolve_namespace {
 395     my $namespace = shift;
 396     my @classes = @_;
 397     return String::RewritePrefix->rewrite(
 398         { '' => $namespace.'::', '+' => '' }, @classes,
 399       );
 400 }
 401
 402
 403 =head1 AUTHORS
 404
 405 Catalyst Contributors, see Catalyst.pm
 406
 407 =head1 COPYRIGHT
 408
 409 This program is free software, you can redistribute it and/or modify it under
 410 the same terms as Perl itself.
 411
 412 =cut
 413
 414 1;