@@ -23,137 +23,139 @@ sub empty {
23
23
}
24
24
25
25
sub add {
26
- if (@_ == 2) {
26
+ if ( @_ == 2 ) {
27
27
my $self = shift ;
28
- push (@$self , shift );
28
+ push ( @$self , shift );
29
29
return ;
30
30
}
31
- my ( $self , %spec ) = @_ ;
32
- push (@$self , \%spec );
31
+ my ( $self , %spec ) = @_ ;
32
+ push ( @$self , \%spec );
33
33
return ;
34
34
}
35
35
36
36
sub find2 {
37
- my ( $self , %spec ) = @_ ;
37
+ my ( $self , %spec ) = @_ ;
38
38
my @found ;
39
39
my @rest ;
40
- ITEM:
40
+ ITEM:
41
41
for my $item (@$self ) {
42
- for my $k (keys %spec ) {
42
+ for my $k ( keys %spec ) {
43
43
no warnings ' uninitialized' ;
44
- if (!exists $item -> {$k } || $spec {$k } ne $item -> {$k }) {
45
- push (@rest , $item );
44
+ if ( !exists $item -> {$k } || $spec {$k } ne $item -> {$k } ) {
45
+ push ( @rest , $item );
46
46
next ITEM;
47
47
}
48
48
}
49
- push (@found , $item );
49
+ push ( @found , $item );
50
50
}
51
51
return \@found unless wantarray ;
52
52
return \@found , \@rest ;
53
53
}
54
54
55
55
sub find {
56
56
my $self = shift ;
57
- my $f = $self -> find2(@_ );
57
+ my $f = $self -> find2(@_ );
58
58
return @$f if wantarray ;
59
59
return $f -> [0];
60
60
}
61
61
62
62
sub remove {
63
- my ( $self , %spec ) = @_ ;
64
- my ( $removed , $rest ) = $self -> find2(%spec );
63
+ my ( $self , %spec ) = @_ ;
64
+ my ( $removed , $rest ) = $self -> find2(%spec );
65
65
@$self = @$rest if @$removed ;
66
66
return @$removed ;
67
67
}
68
68
69
69
my %MATCH = (
70
70
m_scheme => sub {
71
- my ( $v , $uri ) = @_ ;
72
- return $uri -> _scheme eq $v ; # URI known to be canonical
71
+ my ( $v , $uri ) = @_ ;
72
+ return $uri -> _scheme eq $v ; # URI known to be canonical
73
73
},
74
74
m_secure => sub {
75
- my ($v , $uri ) = @_ ;
76
- my $secure = $uri -> can(" secure" ) ? $uri -> secure : $uri -> _scheme eq " https" ;
75
+ my ( $v , $uri ) = @_ ;
76
+ my $secure
77
+ = $uri -> can(" secure" ) ? $uri -> secure : $uri -> _scheme eq " https" ;
77
78
return $secure == !!$v ;
78
79
},
79
80
m_host_port => sub {
80
- my ( $v , $uri ) = @_ ;
81
+ my ( $v , $uri ) = @_ ;
81
82
return unless $uri -> can(" host_port" );
82
83
return $uri -> host_port eq $v , 7;
83
84
},
84
85
m_host => sub {
85
- my ( $v , $uri ) = @_ ;
86
+ my ( $v , $uri ) = @_ ;
86
87
return unless $uri -> can(" host" );
87
88
return $uri -> host eq $v , 6;
88
89
},
89
90
m_port => sub {
90
- my ( $v , $uri ) = @_ ;
91
+ my ( $v , $uri ) = @_ ;
91
92
return unless $uri -> can(" port" );
92
93
return $uri -> port eq $v ;
93
94
},
94
95
m_domain => sub {
95
- my ( $v , $uri ) = @_ ;
96
+ my ( $v , $uri ) = @_ ;
96
97
return unless $uri -> can(" host" );
97
98
my $h = $uri -> host;
98
99
$h = " $h .local" unless $h =~ / \. / ;
99
- $v = " .$v " unless $v =~ / ^\. / ;
100
- return length ($v ), 5 if substr ($h , -length ($v )) eq $v ;
100
+ $v = " .$v " unless $v =~ / ^\. / ;
101
+ return length ($v ), 5 if substr ( $h , -length ($v ) ) eq $v ;
101
102
return 0;
102
103
},
103
104
m_path => sub {
104
- my ( $v , $uri ) = @_ ;
105
+ my ( $v , $uri ) = @_ ;
105
106
return unless $uri -> can(" path" );
106
107
return $uri -> path eq $v , 4;
107
108
},
108
109
m_path_prefix => sub {
109
- my ( $v , $uri ) = @_ ;
110
+ my ( $v , $uri ) = @_ ;
110
111
return unless $uri -> can(" path" );
111
112
my $path = $uri -> path;
112
- my $len = length ($v );
113
+ my $len = length ($v );
113
114
return $len , 3 if $path eq $v ;
114
115
return 0 if length ($path ) <= $len ;
115
116
$v .= " /" unless $v =~ m , /\z , ,;
116
- return $len , 3 if substr ($path , 0, length ($v )) eq $v ;
117
+ return $len , 3 if substr ( $path , 0, length ($v ) ) eq $v ;
117
118
return 0;
118
119
},
119
120
m_path_match => sub {
120
- my ( $v , $uri ) = @_ ;
121
+ my ( $v , $uri ) = @_ ;
121
122
return unless $uri -> can(" path" );
122
123
return $uri -> path =~ $v ;
123
124
},
124
125
m_uri__ => sub {
125
- my ( $v , $k , $uri ) = @_ ;
126
- return unless $uri -> can($k );
126
+ my ( $v , $k , $uri ) = @_ ;
127
+ return unless $uri -> can($k );
127
128
return 1 unless defined $v ;
128
129
return $uri -> $k eq $v ;
129
130
},
130
131
m_method => sub {
131
- my ( $v , $uri , $request ) = @_ ;
132
+ my ( $v , $uri , $request ) = @_ ;
132
133
return $request && $request -> method eq $v ;
133
134
},
134
135
m_proxy => sub {
135
- my ( $v , $uri , $request ) = @_ ;
136
- return $request && ($request -> {proxy } || " " ) eq $v ;
136
+ my ( $v , $uri , $request ) = @_ ;
137
+ return $request && ( $request -> {proxy } || " " ) eq $v ;
137
138
},
138
139
m_code => sub {
139
- my ( $v , $uri , $request , $response ) = @_ ;
140
+ my ( $v , $uri , $request , $response ) = @_ ;
140
141
$v =~ s / xx\z // ;
141
142
return unless $response ;
142
- return length ($v ), 2 if substr ($response -> code, 0, length ($v )) eq $v ;
143
+ return length ($v ), 2
144
+ if substr ( $response -> code, 0, length ($v ) ) eq $v ;
143
145
},
144
- m_media_type => sub { # for request too??
145
- my ( $v , $uri , $request , $response ) = @_ ;
146
+ m_media_type => sub { # for request too??
147
+ my ( $v , $uri , $request , $response ) = @_ ;
146
148
return unless $response ;
147
149
return 1, 1 if $v eq " */*" ;
148
150
my $ct = $response -> content_type;
149
- return 2, 1 if $v =~ s ,/\*\z,, && $ct =~ m , ^\Q $v \E /, ;
150
- return 3, 1 if $v eq " html" && $response -> content_is_html;
151
- return 4, 1 if $v eq " xhtml" && $response -> content_is_xhtml;
151
+ return 2, 1 if $v =~ s ,/\*\z,, && $ct =~ m , ^\Q $v \E /, ;
152
+ return 3, 1 if $v eq " html" && $response -> content_is_html;
153
+ return 4, 1 if $v eq " xhtml" && $response -> content_is_xhtml;
152
154
return 10, 1 if $v eq $ct ;
153
155
return 0;
154
156
},
155
157
m_header__ => sub {
156
- my ( $v , $k , $uri , $request , $response ) = @_ ;
158
+ my ( $v , $k , $uri , $request , $response ) = @_ ;
157
159
return unless $request ;
158
160
my $req_header = $request -> header($k );
159
161
return 1 if defined ($req_header ) && $req_header eq $v ;
@@ -164,7 +166,7 @@ my %MATCH = (
164
166
return 0;
165
167
},
166
168
m_response_attr__ => sub {
167
- my ( $v , $k , $uri , $request , $response ) = @_ ;
169
+ my ( $v , $k , $uri , $request , $response ) = @_ ;
168
170
return unless $response ;
169
171
return 1 if !defined ($v ) && exists $response -> {$k };
170
172
return 0 unless exists $response -> {$k };
@@ -175,45 +177,49 @@ my %MATCH = (
175
177
176
178
sub matching {
177
179
my $self = shift ;
178
- if (@_ == 1) {
179
- if ($_ [0]-> can(" request" )) {
180
- unshift (@_ , $_ [0]-> request);
181
- unshift (@_ , undef ) unless defined $_ [0];
180
+ if ( @_ == 1 ) {
181
+ if ( $_ [0]-> can(" request" ) ) {
182
+ unshift ( @_ , $_ [0]-> request );
183
+ unshift ( @_ , undef ) unless defined $_ [0];
182
184
}
183
- unshift (@_ , $_ [0]-> uri_canonical) if $_ [0] && $_ [0]-> can(" uri_canonical" );
185
+ unshift ( @_ , $_ [0]-> uri_canonical )
186
+ if $_ [0] && $_ [0]-> can(" uri_canonical" );
184
187
}
185
- my ( $uri , $request , $response ) = @_ ;
188
+ my ( $uri , $request , $response ) = @_ ;
186
189
$uri = URI-> new($uri ) unless ref ($uri );
187
190
188
191
my @m ;
189
- ITEM:
192
+ ITEM:
190
193
for my $item (@$self ) {
191
194
my $order ;
192
- for my $ikey (keys %$item ) {
195
+ for my $ikey ( keys %$item ) {
193
196
my $mkey = $ikey ;
194
197
my $k ;
195
198
$k = $1 if $mkey =~ s / __(.*)/ __/ ;
196
- if (my $m = $MATCH {$mkey }) {
199
+ if ( my $m = $MATCH {$mkey } ) {
200
+
197
201
# print "$ikey $mkey\n";
198
- my ( $c , $o );
202
+ my ( $c , $o );
199
203
my @arg = (
200
204
defined ($k ) ? $k : (),
201
205
$uri , $request , $response
202
206
);
203
207
my $v = $item -> {$ikey };
204
208
$v = [$v ] unless ref ($v ) eq " ARRAY" ;
205
209
for (@$v ) {
206
- ($c , $o ) = $m -> ($_ , @arg );
210
+ ( $c , $o ) = $m -> ( $_ , @arg );
211
+
207
212
# print " - $_ ==> $c $o\n";
208
213
last if $c ;
209
214
}
210
215
next ITEM unless $c ;
211
- $order -> [$o || 0] += $c ;
216
+ $order -> [ $o || 0 ] += $c ;
212
217
}
213
218
}
214
219
$order -> [7] ||= 0;
215
- $item -> {_order } = join (" ." , reverse map sprintf (" %03d" , $_ || 0), @$order );
216
- push (@m , $item );
220
+ $item -> {_order }
221
+ = join ( " ." , reverse map sprintf ( " %03d" , $_ || 0 ), @$order );
222
+ push ( @m , $item );
217
223
}
218
224
@m = sort { $b -> {_order } cmp $a -> {_order } } @m ;
219
225
delete $_ -> {_order } for @m ;
@@ -224,7 +230,7 @@ sub matching {
224
230
sub add_item {
225
231
my $self = shift ;
226
232
my $item = shift ;
227
- return $self -> add(item => $item , @_ );
233
+ return $self -> add( item => $item , @_ );
228
234
}
229
235
230
236
sub remove_items {
0 commit comments