File Coverage

blib/lib/Dezi/ReplaceRules.pm
Criterion Covered Total %
statement 69 72 95.8
branch 15 16 93.7
condition n/a
subroutine 12 14 85.7
pod 2 2 100.0
total 98 104 94.2


line stmt bran cond sub pod time code
1             package Dezi::ReplaceRules;
2 12     12   1488 use Moose;
  12         480655  
  12         103  
3             with 'Dezi::Role';
4 12     12   80994 use Scalar::Util qw( blessed );
  12         58  
  12         648  
5 12     12   63 use Carp;
  12         25  
  12         786  
6 12     12   64 use Data::Dump qw( dump );
  12         22  
  12         524  
7 12     12   10696 use Text::ParseWords;
  12         16088  
  12         785  
8 12     12   72 use Try::Tiny;
  12         24  
  12         655  
9 12     12   814 use namespace::autoclean;
  12         8391  
  12         114  
10              
11             our $VERSION = '0.014';
12              
13             has 'rules' => ( is => 'rw', isa => 'ArrayRef' );
14              
15             =pod
16              
17             =head1 NAME
18              
19             Dezi::ReplaceRules - filename mangler
20              
21             =head1 SYNOPSIS
22              
23             use Dezi::ReplaceRules;
24             my $rules = Dezi::ReplaceRules->new(
25             qq(replace "the string you want replaced" "what to change it to"),
26             qq(remove "a string to remove"),
27             qq(prepend "a string to add before the result"),
28             qq(append "a string to add after the result"),
29             qq(regex "/search string/replace string/options"),
30             );
31             my $uri = 'foo/bar/baz';
32             my $modified_uri = $rules->apply($uri);
33              
34             =head1 DESCRIPTION
35              
36             Dezi::ReplaceRules is a pure Perl replacement for the ReplaceRules
37             configuration feature in Swish-e.
38              
39             This class is typically used internally by Dezi. The filter()
40             feature of Dezi is generated to use ReplaceRules if they are defined
41             in a Dezi::Indexer::Config object or config file.
42              
43             =head1 METHODS
44              
45             =head2 new( I<rules> )
46              
47             Constructor for new ReplaceRules object. I<rules> should be an array
48             of strings as defined in
49             L<http://swish-e.org/docs/swish-config.html#replacerules>.
50            
51             =head2 BUILDARGS
52              
53             Internal method. Allows for single argument to new().
54              
55             =head2 BUILD
56              
57             Parses the I<rules> and initializes the object.
58              
59             =head2 rules
60              
61             Get/set the array ref of parsed rules.
62              
63             =cut
64              
65             around BUILDARGS => sub {
66             my $orig = shift;
67             my $class = shift;
68             return $class->$orig( rules => [@_] );
69             };
70              
71             sub BUILD {
72 1     1 1 2 my $self = shift;
73 1         2 $self->{rules} = $self->_parse_rules( @{ $self->{rules} } );
  1         5  
74             }
75              
76             sub _parse_rules {
77 1     1   2 my $self = shift;
78 1         2 my @rules;
79 1         3 for my $r (@_) {
80 5         7 my $rule = {};
81 5         27 my ( $action, $target )
82             = (
83             $r =~ m/^\ *(replace|remove|prepend|append|regex)\s+(.+)$/is );
84 5         9 $action = lc($action);
85 5 100       17 if ( $action eq 'regex' ) {
    100          
86 1         4 ($target) = shellwords($target);
87 1         43 my ( $delim, $before, $after, $opts )
88             = ( $target =~ m!^(.)(.+?)\1(.+?)\1(.+)$! );
89              
90             $rule->{target} = {
91 1         6 delim => $delim,
92             before => $before,
93             after => $after,
94             opts => $opts,
95             };
96              
97             }
98             elsif ( $action eq 'replace' ) {
99 1         6 my ( $before, $after ) = shellwords($target);
100              
101             #warn "before:$before after:$after";
102             $rule->{target} = {
103 1         202 before => $before,
104             after => $after,
105             };
106              
107             }
108             else {
109 3         9 ( $rule->{target} ) = shellwords($target);
110             }
111              
112 5         121 $rule->{action} = $action;
113 5         11 $rule->{orig} = $r;
114 5         11 push @rules, $rule;
115             }
116              
117             #warn "rules: " . dump \@rules;
118              
119 1         37 return \@rules;
120             }
121              
122             =head2 apply( I<string> )
123              
124             Apply the rules in the object against I<string>. Returns a modified
125             copy of I<string>.
126              
127             =cut
128              
129             sub apply {
130 1     1 1 7 my $self = shift;
131 1         4 my $str = shift;
132 1 50       4 if ( !defined $str ) {
133 0         0 croak "string required";
134             }
135              
136             #dump $self;
137              
138 1         2 for my $rule ( @{ $self->{rules} } ) {
  1         4  
139 5         7 my $action = $rule->{action};
140 5         8 my $target = $rule->{target};
141 5         7 my $orig = $rule->{orig};
142              
143             #warn "apply '$orig' to '$str'\n";
144              
145 5 100       13 if ( $action eq 'prepend' ) {
146 1         3 $str = $target . $str;
147             }
148 5 100       11 if ( $action eq 'append' ) {
149 1         3 $str .= $target;
150             }
151 5 100       11 if ( $action eq 'remove' ) {
152 1         9 $str =~ s/$target//g;
153             }
154 5 100       10 if ( $action eq 'replace' ) {
155 1         3 my $b = $target->{before};
156 1         2 my $a = $target->{after};
157             try {
158 1     1   47 $str =~ s/$b/$a/g;
159             }
160             catch {
161 0     0   0 die "Bad rule: $orig ($_)";
162 1         20 };
163             }
164 5 100       30 if ( $action eq 'regex' ) {
165 1         3 my $d = $target->{delim};
166 1         3 my $b = quotemeta( $target->{before} );
167 1         3 my $a = quotemeta( $target->{after} );
168 1         2 my $o = $target->{opts};
169 1         2 my $code = "\$str =~ s/$b/$a/$o";
170              
171             #warn "code='$code'\n";
172             try {
173 1     1   115 eval "$code";
174             }
175             catch {
176 0     0   0 die "Bad rule: $orig ($_)";
177             }
178 1         14 }
179              
180             #warn "$orig applied to '$str'\n";
181             }
182 1         21 return $str;
183             }
184              
185             __PACKAGE__->meta->make_immutable;
186              
187             1;
188              
189             __END__
190              
191             =head1 AUTHOR
192              
193             Peter Karman, E<lt>perl@peknet.comE<gt>
194              
195             =head1 BUGS
196              
197             Please report any bugs or feature requests to C<bug-swish-prog at rt.cpan.org>, or through
198             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Dezi-App>.
199             I will be notified, and then you'll
200             automatically be notified of progress on your bug as I make changes.
201              
202             =head1 SUPPORT
203              
204             You can find documentation for this module with the perldoc command.
205              
206             perldoc Dezi::ReplaceRules
207              
208              
209             You can also look for information at:
210              
211             =over 4
212              
213             =item * Mailing list
214              
215             L<http://lists.swish-e.org/listinfo/users>
216              
217             =item * RT: CPAN's request tracker
218              
219             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dezi-App>
220              
221             =item * AnnoCPAN: Annotated CPAN documentation
222              
223             L<http://annocpan.org/dist/Dezi-App>
224              
225             =item * CPAN Ratings
226              
227             L<http://cpanratings.perl.org/d/Dezi-App>
228              
229             =item * Search CPAN
230              
231             L<http://search.cpan.org/dist/Dezi-App/>
232              
233             =back
234              
235             =head1 COPYRIGHT AND LICENSE
236              
237             Copyright 2011 by Peter Karman
238              
239             This library is free software; you can redistribute it and/or modify
240             it under the same terms as Perl itself.
241              
242             =head1 SEE ALSO
243              
244             L<http://swish-e.org/>, L<http://swish-e.org/docs/swish-config.html#replacerules>