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
  10 =head1 NAME
  11
  12 Catalyst::Utils - The Catalyst Utils
  13
  14 =head1 SYNOPSIS
  15
  16 See L<Catalyst>.
  17
  18 =head1 DESCRIPTION
  19
  20 =head1 METHODS
  21
  22 =head2 appprefix($class)
  23
  24         MyApp::Foo becomes myapp_foo
  25
  26 =cut
  27
  28 sub appprefix {
  29     my $class = shift;
  30     $class =~ s/\:\:/_/g;
  31     $class = lc($class);
  32     return $class;
  33 }
  34
  35 =head2 class2appclass($class);
  36
  37     MyApp::C::Foo::Bar becomes MyApp
  38     My::App::C::Foo::Bar becomes My::App
  39
  40 =cut
  41
  42 sub class2appclass {
  43     my $class = shift || '';
  44     my $appname = '';
  45     if ( $class =~ /^(.*)::([MVC]|Model|View|Controller)?::.*$/ ) {
  46         $appname = $1;
  47     }
  48     return $appname;
  49 }
  50
  51 =head2 class2classprefix($class);
  52
  53     MyApp::C::Foo::Bar becomes MyApp::C
  54     My::App::C::Foo::Bar becomes My::App::C
  55
  56 =cut
  57
  58 sub class2classprefix {
  59     my $class = shift || '';
  60     my $prefix;
  61     if ( $class =~ /^(.*::[MVC]|Model|View|Controller)?::.*$/ ) {
  62         $prefix = $1;
  63     }
  64     return $prefix;
  65 }
  66
  67 =head2 class2classsuffix($class);
  68
  69     MyApp::C::Foo::Bar becomes C::Foo::Bar
  70
  71 =cut
  72
  73 sub class2classsuffix {
  74     my $class = shift || '';
  75     my $prefix = class2appclass($class) || '';
  76     $class =~ s/$prefix\:\://;
  77     return $class;
  78 }
  79
  80 =head2 class2env($class);
  81
  82 Returns the environment name for class.
  83
  84     MyApp becomes MYAPP
  85     My::App becomes MY_APP
  86
  87 =cut
  88
  89 sub class2env {
  90     my $class = shift || '';
  91     $class =~ s/\:\:/_/g;
  92     return uc($class);
  93 }
  94
  95 =head2 class2prefix( $class, $case );
  96
  97 Returns the uri prefix for a class. If case is false the prefix is converted to lowercase.
  98
  99     My::App::C::Foo::Bar becomes foo/bar
 100
 101 =cut
 102
 103 sub class2prefix {
 104     my $class = shift || '';
 105     my $case  = shift || 0;
 106     my $prefix;
 107     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
 108         $prefix = $case ? $2 : lc $2;
 109         $prefix =~ s/\:\:/\//g;
 110     }
 111     return $prefix;
 112 }
 113
 114 =head2 class2tempdir( $class [, $create ] );
 115
 116 Returns a tempdir for a class. If create is true it will try to create the path.
 117
 118     My::App becomes /tmp/my/app
 119     My::App::C::Foo::Bar becomes /tmp/my/app/c/foo/bar
 120
 121 =cut
 122
 123 sub class2tempdir {
 124     my $class  = shift || '';
 125     my $create = shift || 0;
 126     my @parts = split '::', lc $class;
 127
 128     my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup;
 129
 130     if ( $create && !-e $tmpdir ) {
 131
 132         eval { $tmpdir->mkpath };
 133
 134         if ($@) {
 135             Catalyst::Exception->throw(
 136                 message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ );
 137         }
 138     }
 139
 140     return $tmpdir->stringify;
 141 }
 142
 143 =head2 home($class)
 144
 145 Returns home directory for given class.
 146
 147 =cut
 148
 149 sub home {
 150     my $name = shift;
 151     $name =~ s/\:\:/\//g;
 152     my $home = 0;
 153     if ( my $path = $INC{"$name.pm"} ) {
 154         $home = file($path)->absolute->dir;
 155         $name =~ /(\w+)$/;
 156         my $append = $1;
 157         my $subdir = dir($home)->subdir($append);
 158         for ( split '/', $name ) { $home = dir($home)->parent }
 159         if ( $home =~ /blib$/ ) { $home = dir($home)->parent }
 160         elsif (!-f file( $home, 'Makefile.PL' )
 161             && !-f file( $home, 'Build.PL' ) )
 162         {
 163             $home = $subdir;
 164         }
 165
 166         # clean up relative path:
 167         # MyApp/script/.. -> MyApp
 168         my ($lastdir) = $home->dir_list( -1, 1 );
 169         if ( $lastdir eq '..' ) {
 170             $home = dir($home)->parent->parent;
 171         }
 172     }
 173     return $home;
 174 }
 175
 176 =head2 prefix($class, $name);
 177
 178 Returns a prefixed action.
 179
 180     MyApp::C::Foo::Bar, yada becomes foo/bar/yada
 181
 182 =cut
 183
 184 sub prefix {
 185     my ( $class, $name ) = @_;
 186     my $prefix = &class2prefix($class);
 187     $name = "$prefix/$name" if $prefix;
 188     return $name;
 189 }
 190
 191 =head2 request($uri)
 192
 193 Returns an L<HTTP::Request> object for a uri.
 194
 195 =cut
 196
 197 sub request {
 198     my $request = shift;
 199     unless ( ref $request ) {
 200         if ( $request =~ m/^http/i ) {
 201             $request = URI->new($request)->canonical;
 202         }
 203         else {
 204             $request = URI->new( 'http://localhost' . $request )->canonical;
 205         }
 206     }
 207     unless ( ref $request eq 'HTTP::Request' ) {
 208         $request = HTTP::Request->new( 'GET', $request );
 209     }
 210     return $request;
 211 }
 212
 213 =head1 AUTHOR
 214
 215 Sebastian Riedel, C<sri@cpan.org>
 216
 217 =head1 COPYRIGHT
 218
 219 This program is free software, you can redistribute it and/or modify it under
 220 the same terms as Perl itself.
 221
 222 =cut
 223
 224 1;