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