lib/Catalyst/Utils.pm

   1 package Catalyst::Utils;
   2
   3 use strict;
   4 use attributes ();
   5 use Catalyst::Exception;
   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 =over 4
  23
  24 =item attrs($coderef)
  25
  26 Returns attributes for coderef in a arrayref
  27
  28 =cut
  29
  30 sub attrs { attributes::get( $_[0] ) || [] }
  31
  32 =item class2appclass($class);
  33
  34 Returns the appclass for class.
  35
  36     MyApp::C::Foo::Bar becomes MyApp
  37     My::App::C::Foo::Bar becomes My::App
  38
  39 =cut
  40
  41 sub class2appclass {
  42     my $class = shift || '';
  43     my $appname = '';
  44     if ( $class =~ /^(.*)::([MVC]|Model|View|Controller)?::.*$/ ) {
  45         $appname = $1;
  46     }
  47     return $appname;
  48 }
  49
  50 =item class2classprefix($class);
  51
  52 Returns the classprefix for class.
  53
  54     MyApp::C::Foo::Bar becomes MyApp::C
  55     My::App::C::Foo::Bar becomes My::App::C
  56
  57 =cut
  58
  59 sub class2classprefix {
  60     my $class = shift || '';
  61     my $prefix;
  62     if ( $class =~ /^(.*::[MVC]|Model|View|Controller)?::.*$/ ) {
  63         $prefix = $1;
  64     }
  65     return $prefix;
  66 }
  67
  68 =item class2classsuffix($class);
  69
  70 Returns the classsuffix for class.
  71
  72     MyApp::C::Foo::Bar becomes C::Foo::Bar
  73
  74 =cut
  75
  76 sub class2classsuffix {
  77     my $class = shift || '';
  78     my $prefix = class2appclass($class) || '';
  79     $class =~ s/$prefix\:\://;
  80     return $class;
  81 }
  82
  83 =item class2prefix( $class, $case );
  84
  85 Returns the prefix for class.
  86
  87     My::App::C::Foo::Bar becomes /foo/bar
  88
  89 =cut
  90
  91 sub class2prefix {
  92     my $class = shift || '';
  93     my $case  = shift || 0;
  94     my $prefix;
  95     if ( $class =~ /^.*::([MVC]|Model|View|Controller)?::(.*)$/ ) {
  96         $prefix = $case ? $2 : lc $2;
  97         $prefix =~ s/\:\:/\//g;
  98     }
  99     return $prefix;
 100 }
 101
 102 =item home($class)
 103
 104 Returns home directory for given class.
 105
 106 =cut
 107
 108 sub home {
 109     my $name = shift;
 110     $name =~ s/\:\:/\//g;
 111     my $home = 0;
 112     if ( my $path = $INC{"$name.pm"} ) {
 113         $home = file($path)->absolute->dir;
 114         $name =~ /(\w+)$/;
 115         my $append = $1;
 116         my $subdir = dir($home)->subdir($append);
 117         for ( split '/', $name ) { $home = dir($home)->parent }
 118         if ( $home =~ /blib$/ ) { $home = dir($home)->parent }
 119         elsif (!-f file( $home, 'Makefile.PL' )
 120             && !-f file( $home, 'Build.PL' ) )
 121         {
 122             $home = $subdir;
 123         }
 124         # clean up relative path:
 125         # MyApp/script/.. -> MyApp
 126         my ($lastdir) = $home->dir_list( -1, 1 );
 127         if ( $lastdir eq '..' ) {
 128             $home = dir($home)->parent->parent;
 129         }
 130     }
 131     return $home;
 132 }
 133
 134 =item prefix($class, $name);
 135
 136 Returns a prefixed action.
 137
 138     MyApp::C::Foo::Bar, yada becomes /foo/bar/yada
 139
 140 =cut
 141
 142 sub prefix {
 143     my ( $class, $name ) = @_;
 144     my $prefix = &class2prefix($class);
 145     $name = "$prefix/$name" if $prefix;
 146     return $name;
 147 }
 148
 149 =item reflect_actions($class);
 150
 151 Returns an arrayref containing all actions of a component class.
 152
 153 =cut
 154
 155 sub reflect_actions {
 156     my $class   = shift;
 157     my $actions = [];
 158     eval '$actions = $class->_action_cache';
 159
 160     if ( $@ ) {
 161         Catalyst::Exception->throw(
 162             message => qq/Couldn't reflect actions of component "$class", "$@"/
 163         );
 164     }
 165
 166     return $actions;
 167 }
 168
 169 =item request($string);
 170
 171 Returns an C<HTTP::Request> from a string.
 172
 173 =cut
 174
 175 sub request {
 176     my $request = shift;
 177
 178     unless ( ref $request ) {
 179
 180         if ( $request =~ m/http/i ) {
 181             $request = URI->new($request)->canonical;
 182         }
 183         else {
 184             $request = URI->new( 'http://localhost' . $request )->canonical;
 185         }
 186     }
 187
 188     unless ( ref $request eq 'HTTP::Request' ) {
 189         $request = HTTP::Request->new( 'GET', $request );
 190     }
 191
 192     return $request;
 193 }
 194
 195 =back
 196
 197 =head1 AUTHOR
 198
 199 Sebastian Riedel, C<sri@cpan.org>
 200
 201 =head1 COPYRIGHT
 202
 203 This program is free software, you can redistribute it and/or modify it under
 204 the same terms as Perl itself.
 205
 206 =cut
 207
 208 1;