line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Catalyst::Utils; |
2
|
189
|
|
|
189
|
|
533225
|
use strict; |
|
189
|
|
|
|
|
516
|
|
|
189
|
|
|
|
|
6330
|
|
3
|
188
|
|
|
188
|
|
1153
|
use warnings; |
|
188
|
|
|
|
|
451
|
|
|
188
|
|
|
|
|
5536
|
|
4
|
|
|
|
|
|
|
|
5
|
188
|
|
|
188
|
|
1146
|
use File::Spec; |
|
188
|
|
|
|
|
1838
|
|
|
188
|
|
|
|
|
4491
|
|
6
|
188
|
|
|
188
|
|
81481
|
use HTTP::Request; |
|
188
|
|
|
|
|
2848958
|
|
|
188
|
|
|
|
|
6969
|
|
7
|
188
|
|
|
188
|
|
87320
|
use Path::Class; |
|
188
|
|
|
|
|
6681388
|
|
|
188
|
|
|
|
|
12275
|
|
8
|
188
|
|
|
188
|
|
1747
|
use URI; |
|
188
|
|
|
|
|
530
|
|
|
188
|
|
|
|
|
5666
|
|
9
|
188
|
|
|
188
|
|
1123
|
use Carp qw/croak/; |
|
188
|
|
|
|
|
498
|
|
|
188
|
|
|
|
|
8874
|
|
10
|
188
|
|
|
188
|
|
1235
|
use Cwd; |
|
188
|
|
|
|
|
551
|
|
|
188
|
|
|
|
|
10018
|
|
11
|
188
|
|
|
188
|
|
4692
|
use Class::Load 'is_class_loaded'; |
|
188
|
|
|
|
|
119221
|
|
|
188
|
|
|
|
|
9510
|
|
12
|
188
|
|
|
188
|
|
73505
|
use String::RewritePrefix; |
|
188
|
|
|
|
|
219936
|
|
|
188
|
|
|
|
|
1300
|
|
13
|
188
|
|
|
188
|
|
42330
|
use Class::Load (); |
|
188
|
|
|
|
|
509
|
|
|
188
|
|
|
|
|
3332
|
|
14
|
188
|
|
|
188
|
|
9809
|
use namespace::clean; |
|
188
|
|
|
|
|
141073
|
|
|
188
|
|
|
|
|
2135
|
|
15
|
188
|
|
|
188
|
|
152529
|
use Devel::InnerPackage; |
|
188
|
|
|
|
|
373309
|
|
|
188
|
|
|
|
|
8937
|
|
16
|
188
|
|
|
188
|
|
5730
|
use Moose::Util; |
|
188
|
|
|
|
|
847693
|
|
|
188
|
|
|
|
|
2375
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
=head1 NAME |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
Catalyst::Utils - The Catalyst Utils |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 SYNOPSIS |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
See L<Catalyst>. |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 DESCRIPTION |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
Catalyst Utilities. |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 METHODS |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head2 appprefix($class) |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
MyApp::Foo becomes myapp_foo |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=cut |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub appprefix { |
39
|
91
|
|
|
91
|
1
|
367
|
my $class = shift; |
40
|
91
|
|
|
|
|
423
|
$class =~ s/::/_/g; |
41
|
91
|
|
|
|
|
363
|
$class = lc($class); |
42
|
91
|
|
|
|
|
731
|
return $class; |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=head2 class2appclass($class); |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
MyApp::Controller::Foo::Bar becomes MyApp |
48
|
|
|
|
|
|
|
My::App::Controller::Foo::Bar becomes My::App |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
=cut |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
sub class2appclass { |
53
|
7042
|
|
50
|
7042
|
1
|
14393
|
my $class = shift || ''; |
54
|
7042
|
|
|
|
|
11362
|
my $appname = ''; |
55
|
7042
|
100
|
|
|
|
49332
|
if ( $class =~ /^(.+?)::([MVC]|Model|View|Controller)::.+$/ ) { |
56
|
7041
|
|
|
|
|
21552
|
$appname = $1; |
57
|
|
|
|
|
|
|
} |
58
|
7042
|
|
|
|
|
19798
|
return $appname; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
=head2 class2classprefix($class); |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
MyApp::Controller::Foo::Bar becomes MyApp::Controller |
64
|
|
|
|
|
|
|
My::App::Controller::Foo::Bar becomes My::App::Controller |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=cut |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub class2classprefix { |
69
|
1
|
|
50
|
1
|
1
|
7
|
my $class = shift || ''; |
70
|
1
|
|
|
|
|
2
|
my $prefix; |
71
|
1
|
50
|
|
|
|
16
|
if ( $class =~ /^(.+?::([MVC]|Model|View|Controller))::.+$/ ) { |
72
|
1
|
|
|
|
|
3
|
$prefix = $1; |
73
|
|
|
|
|
|
|
} |
74
|
1
|
|
|
|
|
6
|
return $prefix; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=head2 class2classsuffix($class); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
MyApp::Controller::Foo::Bar becomes Controller::Foo::Bar |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=cut |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub class2classsuffix { |
84
|
6957
|
|
50
|
6957
|
1
|
16496
|
my $class = shift || ''; |
85
|
6957
|
|
100
|
|
|
14350
|
my $prefix = class2appclass($class) || ''; |
86
|
6957
|
|
|
|
|
41552
|
$class =~ s/$prefix\:://; |
87
|
6957
|
|
|
|
|
22312
|
return $class; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
=head2 class2env($class); |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
Returns the environment name for class. |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
MyApp becomes MYAPP |
95
|
|
|
|
|
|
|
My::App becomes MY_APP |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=cut |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
sub class2env { |
100
|
1068
|
|
50
|
1068
|
1
|
3784
|
my $class = shift || ''; |
101
|
1068
|
|
|
|
|
3194
|
$class =~ s/::/_/g; |
102
|
1068
|
|
|
|
|
3898
|
return uc($class); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
=head2 class2prefix( $class, $case ); |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
Returns the uri prefix for a class. If case is false the prefix is converted to lowercase. |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
My::App::Controller::Foo::Bar becomes foo/bar |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=cut |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub class2prefix { |
114
|
6177
|
|
50
|
6177
|
1
|
19221
|
my $class = shift || ''; |
115
|
6177
|
|
50
|
|
|
23723
|
my $case = shift || 0; |
116
|
6177
|
|
|
|
|
10426
|
my $prefix; |
117
|
6177
|
100
|
|
|
|
40908
|
if ( $class =~ /^.+?::([MVC]|Model|View|Controller)::(.+)$/ ) { |
118
|
6020
|
50
|
|
|
|
27362
|
$prefix = $case ? $2 : lc $2; |
119
|
6020
|
|
|
|
|
24632
|
$prefix =~ s{::}{/}g; |
120
|
|
|
|
|
|
|
} |
121
|
6177
|
|
|
|
|
29853
|
return $prefix; |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=head2 class2tempdir( $class [, $create ] ); |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Returns a tempdir for a class. If create is true it will try to create the path. |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
My::App becomes /tmp/my/app |
129
|
|
|
|
|
|
|
My::App::Controller::Foo::Bar becomes /tmp/my/app/c/foo/bar |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
=cut |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
sub class2tempdir { |
134
|
0
|
|
0
|
0
|
1
|
0
|
my $class = shift || ''; |
135
|
0
|
|
0
|
|
|
0
|
my $create = shift || 0; |
136
|
0
|
|
|
|
|
0
|
my @parts = split '::', lc $class; |
137
|
|
|
|
|
|
|
|
138
|
0
|
|
|
|
|
0
|
my $tmpdir = dir( File::Spec->tmpdir, @parts )->cleanup; |
139
|
|
|
|
|
|
|
|
140
|
0
|
0
|
0
|
|
|
0
|
if ( $create && !-e $tmpdir ) { |
141
|
|
|
|
|
|
|
|
142
|
0
|
|
|
|
|
0
|
eval { $tmpdir->mkpath; 1 } |
|
0
|
|
|
|
|
0
|
|
143
|
0
|
0
|
|
|
|
0
|
or do { |
144
|
|
|
|
|
|
|
# don't load Catalyst::Exception as a BEGIN in Utils, |
145
|
|
|
|
|
|
|
# because Utils often gets loaded before MyApp.pm, and if |
146
|
|
|
|
|
|
|
# Catalyst::Exception is loaded before MyApp.pm, it does |
147
|
|
|
|
|
|
|
# not honor setting |
148
|
|
|
|
|
|
|
# $Catalyst::Exception::CATALYST_EXCEPTION_CLASS in |
149
|
|
|
|
|
|
|
# MyApp.pm |
150
|
0
|
|
|
|
|
0
|
require Catalyst::Exception; |
151
|
0
|
|
|
|
|
0
|
Catalyst::Exception->throw( |
152
|
|
|
|
|
|
|
message => qq/Couldn't create tmpdir '$tmpdir', "$@"/ ); |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
0
|
|
|
|
|
0
|
return $tmpdir->stringify; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
=head2 home($class) |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
Returns home directory for given class. |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
=head2 dist_indicator_file_list |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
Returns a list of files which can be tested to check if you're inside |
166
|
|
|
|
|
|
|
a CPAN distribution which is not yet installed. |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
These are: |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
=over |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
=item Makefile.PL |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
=item Build.PL |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=item dist.ini |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=item L<cpanfile> |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
=back |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
=cut |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
sub dist_indicator_file_list { |
185
|
259
|
|
|
259
|
1
|
1328
|
qw{Makefile.PL Build.PL dist.ini cpanfile}; |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
sub home { |
189
|
333
|
|
|
333
|
1
|
14850
|
my $class = shift; |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
# make an $INC{ $key } style string from the class name |
192
|
333
|
|
|
|
|
1391
|
(my $file = "$class.pm") =~ s{::}{/}g; |
193
|
|
|
|
|
|
|
|
194
|
333
|
100
|
|
|
|
1518
|
if ( my $inc_entry = $INC{$file} ) { |
195
|
|
|
|
|
|
|
{ |
196
|
|
|
|
|
|
|
# look for an uninstalled Catalyst app |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# find the @INC entry in which $file was found |
199
|
253
|
|
|
|
|
4673
|
(my $path = $inc_entry) =~ s/$file$//; |
200
|
253
|
100
|
33
|
|
|
8715
|
$path ||= cwd() if !defined $path || !length $path; |
|
|
|
66
|
|
|
|
|
201
|
253
|
|
|
|
|
1726
|
my $home = dir($path)->absolute->cleanup; |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# pop off /lib and /blib if they're there |
204
|
253
|
|
|
|
|
68036
|
$home = $home->parent while $home =~ /b?lib$/; |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
# only return the dir if it has a Makefile.PL or Build.PL or dist.ini |
207
|
253
|
100
|
|
|
|
33404
|
if (grep { -f $home->file($_) } dist_indicator_file_list()) { |
|
1012
|
|
|
|
|
107854
|
|
208
|
|
|
|
|
|
|
# clean up relative path: |
209
|
|
|
|
|
|
|
# MyApp/script/.. -> MyApp |
210
|
|
|
|
|
|
|
|
211
|
7
|
|
|
|
|
840
|
my $dir; |
212
|
7
|
|
|
|
|
27
|
my @dir_list = $home->dir_list(); |
213
|
7
|
|
66
|
|
|
130
|
while (($dir = pop(@dir_list)) && $dir eq '..') { |
214
|
6
|
|
|
|
|
537
|
$home = dir($home)->parent->parent; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
7
|
|
|
|
|
509
|
return $home->stringify; |
218
|
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
{ |
222
|
|
|
|
|
|
|
# look for an installed Catalyst app |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# trim the .pm off the thing ( Foo/Bar.pm -> Foo/Bar/ ) |
225
|
253
|
|
|
|
|
551
|
( my $path = $inc_entry) =~ s/\.pm$//; |
|
246
|
|
|
|
|
29578
|
|
|
246
|
|
|
|
|
2184
|
|
226
|
246
|
|
|
|
|
1309
|
my $home = dir($path)->absolute->cleanup; |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# return if it's a valid directory |
229
|
246
|
100
|
|
|
|
36893
|
return $home->stringify if -d $home; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# we found nothing |
234
|
108
|
|
|
|
|
1713
|
return 0; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=head2 prefix($class, $name); |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
Returns a prefixed action. |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
MyApp::Controller::Foo::Bar, yada becomes foo/bar/yada |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=cut |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
sub prefix { |
246
|
0
|
|
|
0
|
1
|
0
|
my ( $class, $name ) = @_; |
247
|
0
|
|
|
|
|
0
|
my $prefix = &class2prefix($class); |
248
|
0
|
0
|
|
|
|
0
|
$name = "$prefix/$name" if $prefix; |
249
|
0
|
|
|
|
|
0
|
return $name; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
=head2 request($uri) |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
Returns an L<HTTP::Request> object for a uri. |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
=cut |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
sub request { |
259
|
920
|
|
|
920
|
1
|
6011
|
my $request = shift; |
260
|
920
|
100
|
|
|
|
3058
|
unless ( ref $request ) { |
261
|
780
|
100
|
|
|
|
4177
|
if ( $request =~ m/^http/i ) { |
262
|
534
|
|
|
|
|
3789
|
$request = URI->new($request); |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
else { |
265
|
246
|
|
|
|
|
2132
|
$request = URI->new( 'http://localhost' . $request ); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
} |
268
|
920
|
100
|
|
|
|
100904
|
unless ( ref $request eq 'HTTP::Request' ) { |
269
|
780
|
|
|
|
|
6000
|
$request = HTTP::Request->new( 'GET', $request ); |
270
|
|
|
|
|
|
|
} |
271
|
920
|
|
|
|
|
71763
|
return $request; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
=head2 ensure_class_loaded($class_name, \%opts) |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
Loads the class unless it already has been loaded. |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
If $opts{ignore_loaded} is true always tries the require whether the package |
279
|
|
|
|
|
|
|
already exists or not. Only pass this if you're either (a) sure you know the |
280
|
|
|
|
|
|
|
file exists on disk or (b) have code to catch the file not found exception |
281
|
|
|
|
|
|
|
that will result if it doesn't. |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=cut |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
sub ensure_class_loaded { |
286
|
6915
|
|
|
6915
|
1
|
27998
|
my $class = shift; |
287
|
6915
|
|
|
|
|
11662
|
my $opts = shift; |
288
|
|
|
|
|
|
|
|
289
|
6915
|
50
|
|
|
|
70731
|
croak "Malformed class Name $class" |
290
|
|
|
|
|
|
|
if $class =~ m/(?:\b\:\b|\:{3,})/; |
291
|
|
|
|
|
|
|
|
292
|
6915
|
100
|
|
|
|
25752
|
croak "Malformed class Name $class" |
293
|
|
|
|
|
|
|
if $class =~ m/[^\w:]/; |
294
|
|
|
|
|
|
|
|
295
|
6913
|
50
|
|
|
|
20260
|
croak "ensure_class_loaded should be given a classname, not a filename ($class)" |
296
|
|
|
|
|
|
|
if $class =~ m/\.pm$/; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
# $opts->{ignore_loaded} can be set to true, and this causes the class to be required, even |
299
|
|
|
|
|
|
|
# if it already has symbol table entries. This is to support things like Schema::Loader, which |
300
|
|
|
|
|
|
|
# part-generate classes in memory, but then also load some of their contents from disk. |
301
|
|
|
|
|
|
|
return if !$opts->{ ignore_loaded } |
302
|
6913
|
100
|
100
|
|
|
27237
|
&& is_class_loaded($class); # if a symbol entry exists we don't load again |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
# this hack is so we don't overwrite $@ if the load did not generate an error |
305
|
6864
|
|
|
|
|
11081
|
my $error; |
306
|
|
|
|
|
|
|
{ |
307
|
6864
|
|
|
|
|
10988
|
local $@; |
|
6864
|
|
|
|
|
11534
|
|
308
|
6864
|
|
|
|
|
20180
|
my $file = $class . '.pm'; |
309
|
6864
|
|
|
|
|
34632
|
$file =~ s{::}{/}g; |
310
|
6864
|
|
|
|
|
16171
|
eval { CORE::require($file) }; |
|
6864
|
|
|
|
|
3020739
|
|
311
|
6864
|
|
|
|
|
109402884
|
$error = $@; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
6864
|
100
|
|
|
|
24653
|
die $error if $error; |
315
|
|
|
|
|
|
|
|
316
|
6862
|
100
|
|
|
|
39584
|
warn "require $class was successful but the package is not defined." |
317
|
|
|
|
|
|
|
unless is_class_loaded($class); |
318
|
|
|
|
|
|
|
|
319
|
6862
|
|
|
|
|
35628
|
return 1; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
=head2 merge_hashes($hashref, $hashref) |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
Base code to recursively merge two hashes together with right-hand precedence. |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=cut |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub merge_hashes { |
329
|
22511
|
|
|
22511
|
1
|
43910
|
my ( $lefthash, $righthash ) = @_; |
330
|
|
|
|
|
|
|
|
331
|
22511
|
100
|
|
|
|
52822
|
return $lefthash unless defined $righthash; |
332
|
|
|
|
|
|
|
|
333
|
21764
|
|
|
|
|
57857
|
my %merged = %$lefthash; |
334
|
21764
|
|
|
|
|
61342
|
for my $key ( keys %$righthash ) { |
335
|
8813
|
|
100
|
|
|
42514
|
my $right_ref = ( ref $righthash->{ $key } || '' ) eq 'HASH'; |
336
|
8813
|
|
100
|
|
|
39100
|
my $left_ref = ( ( exists $lefthash->{ $key } && ref $lefthash->{ $key } ) || '' ) eq 'HASH'; |
337
|
8813
|
100
|
100
|
|
|
26720
|
if( $right_ref and $left_ref ) { |
338
|
|
|
|
|
|
|
$merged{ $key } = merge_hashes( |
339
|
81
|
|
|
|
|
663
|
$lefthash->{ $key }, $righthash->{ $key } |
340
|
|
|
|
|
|
|
); |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
else { |
343
|
8732
|
|
|
|
|
24226
|
$merged{ $key } = $righthash->{ $key }; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
21764
|
|
|
|
|
85389
|
return \%merged; |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
=head2 env_value($class, $key) |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
Checks for and returns an environment value. For instance, if $key is |
353
|
|
|
|
|
|
|
'home', then this method will check for and return the first value it finds, |
354
|
|
|
|
|
|
|
looking at $ENV{MYAPP_HOME} and $ENV{CATALYST_HOME}. |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
=cut |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub env_value { |
359
|
1067
|
|
|
1067
|
1
|
5514
|
my ( $class, $key ) = @_; |
360
|
|
|
|
|
|
|
|
361
|
1067
|
|
|
|
|
3479
|
$key = uc($key); |
362
|
1067
|
|
|
|
|
3744
|
my @prefixes = ( class2env($class), 'CATALYST' ); |
363
|
|
|
|
|
|
|
|
364
|
1067
|
|
|
|
|
3136
|
for my $prefix (@prefixes) { |
365
|
2126
|
100
|
|
|
|
9358
|
if ( defined( my $value = $ENV{"${prefix}_${key}"} ) ) { |
366
|
26
|
|
|
|
|
469
|
return $value; |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
1041
|
|
|
|
|
6364
|
return; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
=head2 term_width |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
Try to guess terminal width to use with formatting of debug output |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
All you need to get this work, is: |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
1) Install Term::Size::Any, or |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
2) Export $COLUMNS from your shell. |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
(Warning to bash users: 'echo $COLUMNS' may be showing you the bash |
384
|
|
|
|
|
|
|
variable, not $ENV{COLUMNS}. 'export COLUMNS=$COLUMNS' and you should see |
385
|
|
|
|
|
|
|
that 'env' now lists COLUMNS.) |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
As last resort, default value of 80 chars will be used. |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
Calling C<term_width> with a true value will cause it to be recalculated; you |
390
|
|
|
|
|
|
|
can use this to cause it to get recalculated when your terminal is resized like |
391
|
|
|
|
|
|
|
this |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
$SIG{WINCH} = sub { Catalyst::Utils::term_width(1) }; |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
=cut |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
my $_term_width; |
398
|
|
|
|
|
|
|
my $_use_term_size_any; |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
sub term_width { |
401
|
68
|
|
|
68
|
1
|
146
|
my $force_reset = shift; |
402
|
|
|
|
|
|
|
|
403
|
68
|
50
|
|
|
|
181
|
undef $_term_width if $force_reset; |
404
|
|
|
|
|
|
|
|
405
|
68
|
100
|
|
|
|
403
|
return $_term_width if $_term_width; |
406
|
|
|
|
|
|
|
|
407
|
8
|
50
|
33
|
|
|
66
|
if ($ENV{COLUMNS} && $ENV{COLUMNS} =~ /\A\d+\z/) { |
408
|
0
|
|
|
|
|
0
|
return $_term_width = $ENV{COLUMNS}; |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
8
|
50
|
33
|
|
|
171
|
if (!-t STDOUT && !-t STDERR) { |
412
|
8
|
|
|
|
|
82
|
return $_term_width = 80; |
413
|
|
|
|
|
|
|
} |
414
|
|
|
|
|
|
|
|
415
|
0
|
0
|
|
|
|
0
|
if (!defined $_use_term_size_any) { |
416
|
|
|
|
|
|
|
eval { |
417
|
0
|
|
|
|
|
0
|
require Term::Size::Any; |
418
|
0
|
|
|
|
|
0
|
Term::Size::Any->import(); |
419
|
0
|
|
|
|
|
0
|
$_use_term_size_any = 1; |
420
|
0
|
|
|
|
|
0
|
1; |
421
|
0
|
0
|
|
|
|
0
|
} or do { |
422
|
0
|
0
|
|
|
|
0
|
if ( $@ =~ m[Can't locate Term/Size/Any\.pm] ) { |
423
|
0
|
|
|
|
|
0
|
warn "Term::Size::Any is not installed, can't autodetect terminal column width\n"; |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
else { |
426
|
0
|
|
|
|
|
0
|
warn "There was an error trying to detect your terminal size: $@\n"; |
427
|
|
|
|
|
|
|
} |
428
|
0
|
|
|
|
|
0
|
$_use_term_size_any = 0; |
429
|
|
|
|
|
|
|
}; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
0
|
|
|
|
|
0
|
my $width; |
433
|
|
|
|
|
|
|
|
434
|
0
|
0
|
|
|
|
0
|
if ($_use_term_size_any) { |
435
|
0
|
|
0
|
|
|
0
|
$width = Term::Size::Any::chars(*STDERR) || Term::Size::Any::chars(*STDOUT); |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
0
|
0
|
0
|
|
|
0
|
if (!$width || $width < 80) { |
439
|
0
|
|
|
|
|
0
|
$width = 80; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
0
|
|
|
|
|
0
|
return $_term_width = $width; |
443
|
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
=head2 resolve_namespace |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
Method which adds the namespace for plugins and actions. |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
__PACKAGE__->setup(qw(MyPlugin)); |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
# will load Catalyst::Plugin::MyPlugin |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
=cut |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
sub resolve_namespace { |
458
|
2227
|
|
|
2227
|
1
|
5211
|
my $appnamespace = shift; |
459
|
2227
|
|
|
|
|
4598
|
my $namespace = shift; |
460
|
2227
|
|
|
|
|
5920
|
my @classes = @_; |
461
|
2227
|
100
|
|
|
|
21638
|
return String::RewritePrefix->rewrite({ |
462
|
|
|
|
|
|
|
q[] => qq[${namespace}::], |
463
|
|
|
|
|
|
|
q[+] => q[], |
464
|
|
|
|
|
|
|
(defined $appnamespace |
465
|
|
|
|
|
|
|
? (q[~] => qq[${appnamespace}::]) |
466
|
|
|
|
|
|
|
: () |
467
|
|
|
|
|
|
|
), |
468
|
|
|
|
|
|
|
}, @classes); |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
=head2 build_middleware (@args) |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
Internal application that converts a single middleware definition (see |
474
|
|
|
|
|
|
|
L<Catalyst/psgi_middleware>) into an actual instance of middleware. |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=cut |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
sub build_middleware { |
479
|
10
|
|
|
10
|
1
|
37
|
my ($class, $namespace, @init_args) = @_; |
480
|
|
|
|
|
|
|
|
481
|
10
|
100
|
66
|
|
|
155
|
if( |
|
|
|
66
|
|
|
|
|
482
|
|
|
|
|
|
|
$namespace =~s/^\+// || |
483
|
|
|
|
|
|
|
$namespace =~/^Plack::Middleware/ || |
484
|
|
|
|
|
|
|
$namespace =~/^$class/ |
485
|
|
|
|
|
|
|
) { ## the string is a full namespace |
486
|
3
|
50
|
|
|
|
31
|
return Class::Load::try_load_class($namespace) ? |
487
|
|
|
|
|
|
|
$namespace->new(@init_args) : |
488
|
|
|
|
|
|
|
die "Can't load class $namespace"; |
489
|
|
|
|
|
|
|
} else { ## the string is a partial namespace |
490
|
7
|
50
|
|
|
|
45
|
if(Class::Load::try_load_class($class .'::Middleware::'. $namespace)) { ## Load Middleware from Project namespace |
|
|
100
|
|
|
|
|
|
491
|
0
|
|
|
|
|
0
|
my $ns = $class .'::Middleware::'. $namespace; |
492
|
0
|
|
|
|
|
0
|
return $ns->new(@init_args); |
493
|
|
|
|
|
|
|
} elsif(Class::Load::try_load_class("Plack::Middleware::$namespace")) { ## Act like Plack::Builder |
494
|
6
|
|
|
|
|
4508
|
return "Plack::Middleware::$namespace"->new(@init_args); |
495
|
|
|
|
|
|
|
} else { |
496
|
1
|
|
|
|
|
751
|
die "Can't load middleware via '$namespace'. It's not ".$class."::Middleware::".$namespace." or Plack::Middleware::$namespace"; |
497
|
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
|
500
|
0
|
|
|
|
|
0
|
return; ## be sure we can count on a proper return when valid |
501
|
|
|
|
|
|
|
} |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
=head2 apply_registered_middleware ($psgi) |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
Given a $psgi reference, wrap all the L<Catalyst/registered_middlewares> |
506
|
|
|
|
|
|
|
around it and return the wrapped version. |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
This exists to deal with the fact Catalyst registered middleware can be |
509
|
|
|
|
|
|
|
either an object with a wrap method or a coderef. |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
=cut |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub apply_registered_middleware { |
514
|
135
|
|
|
135
|
1
|
632
|
my ($class, $psgi) = @_; |
515
|
135
|
|
|
|
|
412
|
my $new_psgi = $psgi; |
516
|
135
|
|
|
|
|
1470
|
foreach my $middleware ($class->registered_middlewares) { |
517
|
958
|
100
|
|
|
|
47872
|
$new_psgi = Scalar::Util::blessed $middleware ? |
518
|
|
|
|
|
|
|
$middleware->wrap($new_psgi) : |
519
|
|
|
|
|
|
|
$middleware->($new_psgi); |
520
|
|
|
|
|
|
|
} |
521
|
135
|
|
|
|
|
8303
|
return $new_psgi; |
522
|
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
=head2 inject_component |
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
Used to add components at runtime: |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
into The Catalyst package to inject into (e.g. My::App) |
529
|
|
|
|
|
|
|
component The component package to inject |
530
|
|
|
|
|
|
|
traits (Optional) ArrayRef of L<Moose::Role>s that the component should consume. |
531
|
|
|
|
|
|
|
as An optional moniker to use as the package name for the derived component |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
For example: |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple ) |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
The above will create 'My::App::Controller::Other::App::Controller::Apple' |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple ) |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
The above will create 'My::App::Controller::Apple' |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' ); |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
Will inject Controller, Model, and View components into your Catalyst application |
546
|
|
|
|
|
|
|
at setup (run)time. It does this by creating a new package on-the-fly, having that |
547
|
|
|
|
|
|
|
package extend the given component, and then having Catalyst setup the new component |
548
|
|
|
|
|
|
|
(via $app->setup_component). |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>. If you were using that |
551
|
|
|
|
|
|
|
you can now use this safely instead. Going forward changes required to make this work will be |
552
|
|
|
|
|
|
|
synchronized with the core method. |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
B<NOTE:> The 'traits' option is unique to the L<Catalyst::Utils> version of this feature. |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
B<NOTE:> These injected components really need to be a L<Catalyst::Component> and a L<Moose> |
557
|
|
|
|
|
|
|
based class. |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
=cut |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
sub inject_component { |
562
|
11
|
|
|
11
|
1
|
118
|
my %given = @_; |
563
|
11
|
|
|
|
|
37
|
my ($into, $component, $as) = @given{qw/into component as/}; |
564
|
|
|
|
|
|
|
|
565
|
11
|
50
|
|
|
|
25
|
croak "No Catalyst (package) given" unless $into; |
566
|
11
|
50
|
|
|
|
24
|
croak "No component (package) given" unless $component; |
567
|
|
|
|
|
|
|
|
568
|
11
|
|
|
|
|
40
|
Class::Load::load_class($component); |
569
|
|
|
|
|
|
|
|
570
|
11
|
|
66
|
|
|
16890
|
$as ||= $component; |
571
|
11
|
50
|
66
|
|
|
74
|
unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) { |
572
|
5
|
|
|
|
|
13
|
my $category; |
573
|
5
|
|
|
|
|
13
|
for (qw/ Controller Model View /) { |
574
|
7
|
100
|
|
|
|
53
|
if ( $component->isa( "Catalyst::$_" ) ) { |
575
|
5
|
|
|
|
|
10
|
$category = $_; |
576
|
5
|
|
|
|
|
11
|
last; |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
} |
579
|
5
|
50
|
|
|
|
22
|
croak "Don't know what kind of component \"$component\" is" unless $category; |
580
|
5
|
|
|
|
|
17
|
$as = "${category}::$as"; |
581
|
|
|
|
|
|
|
} |
582
|
11
|
|
|
|
|
52
|
my $component_package = join '::', $into, $as; |
583
|
|
|
|
|
|
|
|
584
|
11
|
50
|
|
|
|
50
|
unless ( Class::Load::is_class_loaded $component_package ) { |
585
|
11
|
50
|
|
2
|
|
1152
|
eval "package $component_package; use base qw/$component/; 1;" or |
|
2
|
|
|
2
|
|
17
|
|
|
2
|
|
|
2
|
|
6
|
|
|
2
|
|
|
2
|
|
290
|
|
|
2
|
|
|
2
|
|
23
|
|
|
2
|
|
|
|
|
16
|
|
|
2
|
|
|
|
|
207
|
|
|
2
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
18
|
|
|
2
|
|
|
|
|
175
|
|
|
2
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
163
|
|
|
2
|
|
|
|
|
31
|
|
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
209
|
|
586
|
|
|
|
|
|
|
croak "Unable to build component package for \"$component_package\": $@"; |
587
|
11
|
100
|
|
|
|
54
|
Moose::Util::apply_all_roles($component_package, @{$given{traits}}) if $given{traits}; |
|
3
|
|
|
|
|
15
|
|
588
|
11
|
|
|
|
|
24847
|
(my $file = "$component_package.pm") =~ s{::}{/}g; |
589
|
11
|
|
50
|
|
|
73
|
$INC{$file} ||= 1; |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
my $_setup_component = sub { |
593
|
11
|
|
|
11
|
|
24
|
my $into = shift; |
594
|
11
|
|
|
|
|
18
|
my $component_package = shift; |
595
|
11
|
|
|
|
|
48
|
$into->components->{$component_package} = $into->delayed_setup_component( $component_package ); |
596
|
11
|
|
|
|
|
47
|
}; |
597
|
|
|
|
|
|
|
|
598
|
11
|
|
|
|
|
30
|
$_setup_component->( $into, $component_package ); |
599
|
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
=head1 PSGI Helpers |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
Utility functions to make it easier to work with PSGI applications under Catalyst |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
=head2 env_at_path_prefix |
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
Localize C<$env> under the current controller path prefix: |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
package MyApp::Controller::User; |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
use Catalyst::Utils; |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
use base 'Catalyst::Controller'; |
614
|
|
|
|
|
|
|
|
615
|
|
|
|
|
|
|
sub name :Local { |
616
|
|
|
|
|
|
|
my ($self, $c) = @_; |
617
|
|
|
|
|
|
|
my $env = $c->Catalyst::Utils::env_at_path_prefix; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
Assuming you have a request like GET /user/name: |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
In the example case C<$env> will have PATH_INFO of '/name' instead of |
623
|
|
|
|
|
|
|
'/user/name' and SCRIPT_NAME will now be '/user'. |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
=cut |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
sub env_at_path_prefix { |
628
|
8
|
|
|
8
|
1
|
107
|
my $ctx = shift; |
629
|
8
|
|
|
|
|
43
|
my $path_prefix = $ctx->controller->path_prefix; |
630
|
8
|
|
|
|
|
210
|
my $env = $ctx->request->env; |
631
|
8
|
|
|
|
|
56
|
my $path_info = $env->{PATH_INFO}; |
632
|
8
|
|
50
|
|
|
52
|
my $script_name = ($env->{SCRIPT_NAME} || ''); |
633
|
|
|
|
|
|
|
|
634
|
8
|
|
|
|
|
88
|
$path_info =~ s/(^\/\Q$path_prefix\E)//; |
635
|
8
|
|
|
|
|
29
|
$script_name = "$script_name$1"; |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
return +{ |
638
|
8
|
|
|
|
|
208
|
%$env, |
639
|
|
|
|
|
|
|
PATH_INFO => $path_info, |
640
|
|
|
|
|
|
|
SCRIPT_NAME => $script_name }; |
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
=head2 env_at_action |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
Localize C<$env> under the current action namespace. |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
package MyApp::Controller::User; |
648
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
use Catalyst::Utils; |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
use base 'Catalyst::Controller'; |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
sub name :Local { |
654
|
|
|
|
|
|
|
my ($self, $c) = @_; |
655
|
|
|
|
|
|
|
my $env = $c->Catalyst::Utils::env_at_action; |
656
|
|
|
|
|
|
|
} |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
Assuming you have a request like GET /user/name: |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
In the example case C<$env> will have PATH_INFO of '/' instead of |
661
|
|
|
|
|
|
|
'/user/name' and SCRIPT_NAME will now be '/user/name'. |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
Alternatively, assuming you have a request like GET /user/name/foo: |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
In this example case C<$env> will have PATH_INFO of '/foo' instead of |
666
|
|
|
|
|
|
|
'/user/name/foo' and SCRIPT_NAME will now be '/user/name'. |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
This is probably a common case where you want to mount a PSGI application |
669
|
|
|
|
|
|
|
under an action but let the Args fall through to the PSGI app. |
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
=cut |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
sub env_at_action { |
674
|
11
|
|
|
11
|
1
|
119
|
my $ctx = shift; |
675
|
11
|
|
|
|
|
24
|
my $argpath = join '/', @{$ctx->request->arguments}; |
|
11
|
|
|
|
|
275
|
|
676
|
11
|
|
|
|
|
258
|
my $path = '/' . $ctx->request->path; |
677
|
|
|
|
|
|
|
|
678
|
11
|
|
|
|
|
456
|
$path =~ s/\/?\Q$argpath\E\/?$//; |
679
|
|
|
|
|
|
|
|
680
|
11
|
|
|
|
|
305
|
my $env = $ctx->request->env; |
681
|
11
|
|
|
|
|
39
|
my $path_info = $env->{PATH_INFO}; |
682
|
11
|
|
50
|
|
|
64
|
my $script_name = ($env->{SCRIPT_NAME} || ''); |
683
|
|
|
|
|
|
|
|
684
|
11
|
|
|
|
|
194
|
$path_info =~ s/(^\Q$path\E)//; |
685
|
11
|
|
|
|
|
49
|
$script_name = "$script_name$1"; |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
return +{ |
688
|
11
|
|
|
|
|
263
|
%$env, |
689
|
|
|
|
|
|
|
PATH_INFO => $path_info, |
690
|
|
|
|
|
|
|
SCRIPT_NAME => $script_name }; |
691
|
|
|
|
|
|
|
} |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
=head2 env_at_request_uri |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
Localize C<$env> under the current request URI: |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
package MyApp::Controller::User; |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
use Catalyst::Utils; |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
use base 'Catalyst::Controller'; |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
sub name :Local Args(1) { |
704
|
|
|
|
|
|
|
my ($self, $c, $id) = @_; |
705
|
|
|
|
|
|
|
my $env = $c->Catalyst::Utils::env_at_request_uri |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
Assuming you have a request like GET /user/name/hello: |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
In the example case C<$env> will have PATH_INFO of '/' instead of |
711
|
|
|
|
|
|
|
'/user/name' and SCRIPT_NAME will now be '/user/name/hello'. |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
=cut |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
sub env_at_request_uri { |
716
|
7
|
|
|
7
|
1
|
96
|
my $ctx = shift; |
717
|
7
|
|
|
|
|
583
|
my $path = '/' . $ctx->request->path; |
718
|
7
|
|
|
|
|
194
|
my $env = $ctx->request->env; |
719
|
7
|
|
|
|
|
40
|
my $path_info = $env->{PATH_INFO}; |
720
|
7
|
|
50
|
|
|
47
|
my $script_name = ($env->{SCRIPT_NAME} || ''); |
721
|
|
|
|
|
|
|
|
722
|
7
|
|
|
|
|
199
|
$path_info =~ s/(^\Q$path\E)//; |
723
|
7
|
|
|
|
|
37
|
$script_name = "$script_name$1"; |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
return +{ |
726
|
7
|
|
|
|
|
178
|
%$env, |
727
|
|
|
|
|
|
|
PATH_INFO => $path_info, |
728
|
|
|
|
|
|
|
SCRIPT_NAME => $script_name }; |
729
|
|
|
|
|
|
|
} |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
=head1 AUTHORS |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
Catalyst Contributors, see Catalyst.pm |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
=head1 COPYRIGHT |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
This library is free software. You can redistribute it and/or modify it under |
738
|
|
|
|
|
|
|
the same terms as Perl itself. |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
=cut |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
1; |