← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:12:19 2013

Filename/usr/lib/perl/5.10/File/GlobMapper.pm
StatementsExecuted 29 statements in 2.43ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1111.21ms2.21msFile::GlobMapper::::BEGIN@10File::GlobMapper::BEGIN@10
11135µs41µsFile::GlobMapper::::BEGIN@3File::GlobMapper::BEGIN@3
11116µs66µsFile::GlobMapper::::BEGIN@5File::GlobMapper::BEGIN@5
11116µs40µsFile::GlobMapper::::BEGIN@341File::GlobMapper::BEGIN@341
11114µs31µsFile::GlobMapper::::BEGIN@4File::GlobMapper::BEGIN@4
0000s0sFile::GlobMapper::::_getFilesFile::GlobMapper::_getFiles
0000s0sFile::GlobMapper::::_parseBitFile::GlobMapper::_parseBit
0000s0sFile::GlobMapper::::_parseInputGlobFile::GlobMapper::_parseInputGlob
0000s0sFile::GlobMapper::::_parseOutputGlobFile::GlobMapper::_parseOutputGlob
0000s0sFile::GlobMapper::::_retErrorFile::GlobMapper::_retError
0000s0sFile::GlobMapper::::_unmatchedFile::GlobMapper::_unmatched
0000s0sFile::GlobMapper::::getFileMapFile::GlobMapper::getFileMap
0000s0sFile::GlobMapper::::getHashFile::GlobMapper::getHash
0000s0sFile::GlobMapper::::globmapFile::GlobMapper::globmap
0000s0sFile::GlobMapper::::newFile::GlobMapper::new
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package File::GlobMapper;
2
3338µs248µs
# spent 41µs (35+7) within File::GlobMapper::BEGIN@3 which was called: # once (35µs+7µs) by IO::Compress::Base::Common::BEGIN@9 at line 3
use strict;
# spent 41µs making 1 call to File::GlobMapper::BEGIN@3 # spent 7µs making 1 call to strict::import
4351µs248µs
# spent 31µs (14+17) within File::GlobMapper::BEGIN@4 which was called: # once (14µs+17µs) by IO::Compress::Base::Common::BEGIN@9 at line 4
use warnings;
# spent 31µs making 1 call to File::GlobMapper::BEGIN@4 # spent 17µs making 1 call to warnings::import
53204µs2115µs
# spent 66µs (16+49) within File::GlobMapper::BEGIN@5 which was called: # once (16µs+49µs) by IO::Compress::Base::Common::BEGIN@9 at line 5
use Carp;
# spent 66µs making 1 call to File::GlobMapper::BEGIN@5 # spent 49µs making 1 call to Exporter::import
6
71300nsour ($CSH_GLOB);
8
9BEGIN
10
# spent 2.21ms (1.21+999µs) within File::GlobMapper::BEGIN@10 which was called: # once (1.21ms+999µs) by IO::Compress::Base::Common::BEGIN@9 at line 24
{
1119µs if ($] < 5.006)
12 {
13 require File::BSDGlob; import File::BSDGlob qw(:glob) ;
14 $CSH_GLOB = File::BSDGlob::GLOB_CSH() ;
15 *globber = \&File::BSDGlob::csh_glob;
16 }
17 else
18 {
19296µs111µs require File::Glob; import File::Glob qw(:glob) ;
# spent 11µs making 1 call to File::Glob::import
2013µs118µs $CSH_GLOB = File::Glob::GLOB_CSH() ;
# spent 18µs making 1 call to File::Glob::GLOB_CSH
21 #*globber = \&File::Glob::bsd_glob;
2212µs *globber = \&File::Glob::csh_glob;
23 }
2411.71ms12.21ms}
# spent 2.21ms making 1 call to File::GlobMapper::BEGIN@10
25
261100nsour ($Error);
27
281700nsour ($VERSION, @EXPORT_OK);
291700ns$VERSION = '1.000';
3012µs@EXPORT_OK = qw( globmap );
31
32
331600nsour ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
341700ns$noPreBS = '(?<!\\\)' ; # no preceeding backslash
351300ns$metachars = '.*?[](){}';
3612µs$matchMetaRE = '[' . quotemeta($metachars) . ']';
37
3816µs%mapping = (
39 '*' => '([^/]*)',
40 '?' => '([^/])',
41 '.' => '\.',
42 '[' => '([',
43 '(' => '(',
44 ')' => ')',
45 );
46
47116µs%wildCount = map { $_ => 1 } qw/ * ? . { ( [ /;
48
49sub globmap ($$;)
50{
51 my $inputGlob = shift ;
52 my $outputGlob = shift ;
53
54 my $obj = new File::GlobMapper($inputGlob, $outputGlob, @_)
55 or croak "globmap: $Error" ;
56 return $obj->getFileMap();
57}
58
59sub new
60{
61 my $class = shift ;
62 my $inputGlob = shift ;
63 my $outputGlob = shift ;
64 # TODO -- flags needs to default to whatever File::Glob does
65 my $flags = shift || $CSH_GLOB ;
66 #my $flags = shift ;
67
68 $inputGlob =~ s/^\s*\<\s*//;
69 $inputGlob =~ s/\s*\>\s*$//;
70
71 $outputGlob =~ s/^\s*\<\s*//;
72 $outputGlob =~ s/\s*\>\s*$//;
73
74 my %object =
75 ( InputGlob => $inputGlob,
76 OutputGlob => $outputGlob,
77 GlobFlags => $flags,
78 Braces => 0,
79 WildCount => 0,
80 Pairs => [],
81 Sigil => '#',
82 );
83
84 my $self = bless \%object, ref($class) || $class ;
85
86 $self->_parseInputGlob()
87 or return undef ;
88
89 $self->_parseOutputGlob()
90 or return undef ;
91
92 my @inputFiles = globber($self->{InputGlob}, $flags) ;
93
94 if (GLOB_ERROR)
95 {
96 $Error = $!;
97 return undef ;
98 }
99
100 #if (whatever)
101 {
102 my $missing = grep { ! -e $_ } @inputFiles ;
103
104 if ($missing)
105 {
106 $Error = "$missing input files do not exist";
107 return undef ;
108 }
109 }
110
111 $self->{InputFiles} = \@inputFiles ;
112
113 $self->_getFiles()
114 or return undef ;
115
116 return $self;
117}
118
119sub _retError
120{
121 my $string = shift ;
122 $Error = "$string in input fileglob" ;
123 return undef ;
124}
125
126sub _unmatched
127{
128 my $delimeter = shift ;
129
130 _retError("Unmatched $delimeter");
131 return undef ;
132}
133
134sub _parseBit
135{
136 my $self = shift ;
137
138 my $string = shift ;
139
140 my $out = '';
141 my $depth = 0 ;
142
143 while ($string =~ s/(.*?)$noPreBS(,|$matchMetaRE)//)
144 {
145 $out .= quotemeta($1) ;
146 $out .= $mapping{$2} if defined $mapping{$2};
147
148 ++ $self->{WildCount} if $wildCount{$2} ;
149
150 if ($2 eq ',')
151 {
152 return _unmatched "("
153 if $depth ;
154
155 $out .= '|';
156 }
157 elsif ($2 eq '(')
158 {
159 ++ $depth ;
160 }
161 elsif ($2 eq ')')
162 {
163 return _unmatched ")"
164 if ! $depth ;
165
166 -- $depth ;
167 }
168 elsif ($2 eq '[')
169 {
170 # TODO -- quotemeta & check no '/'
171 # TODO -- check for \] & other \ within the []
172 $string =~ s#(.*?\])##
173 or return _unmatched "[" ;
174 $out .= "$1)" ;
175 }
176 elsif ($2 eq ']')
177 {
178 return _unmatched "]" ;
179 }
180 elsif ($2 eq '{' || $2 eq '}')
181 {
182 return _retError "Nested {} not allowed" ;
183 }
184 }
185
186 $out .= quotemeta $string;
187
188 return _unmatched "("
189 if $depth ;
190
191 return $out ;
192}
193
194sub _parseInputGlob
195{
196 my $self = shift ;
197
198 my $string = $self->{InputGlob} ;
199 my $inGlob = '';
200
201 # Multiple concatenated *'s don't make sense
202 #$string =~ s#\*\*+#*# ;
203
204 # TODO -- Allow space to delimit patterns?
205 #my @strings = split /\s+/, $string ;
206 #for my $str (@strings)
207 my $out = '';
208 my $depth = 0 ;
209
210 while ($string =~ s/(.*?)$noPreBS($matchMetaRE)//)
211 {
212 $out .= quotemeta($1) ;
213 $out .= $mapping{$2} if defined $mapping{$2};
214 ++ $self->{WildCount} if $wildCount{$2} ;
215
216 if ($2 eq '(')
217 {
218 ++ $depth ;
219 }
220 elsif ($2 eq ')')
221 {
222 return _unmatched ")"
223 if ! $depth ;
224
225 -- $depth ;
226 }
227 elsif ($2 eq '[')
228 {
229 # TODO -- quotemeta & check no '/' or '(' or ')'
230 # TODO -- check for \] & other \ within the []
231 $string =~ s#(.*?\])##
232 or return _unmatched "[";
233 $out .= "$1)" ;
234 }
235 elsif ($2 eq ']')
236 {
237 return _unmatched "]" ;
238 }
239 elsif ($2 eq '}')
240 {
241 return _unmatched "}" ;
242 }
243 elsif ($2 eq '{')
244 {
245 # TODO -- check no '/' within the {}
246 # TODO -- check for \} & other \ within the {}
247
248 my $tmp ;
249 unless ( $string =~ s/(.*?)$noPreBS\}//)
250 {
251 return _unmatched "{";
252 }
253 #$string =~ s#(.*?)\}##;
254
255 #my $alt = join '|',
256 # map { quotemeta $_ }
257 # split "$noPreBS,", $1 ;
258 my $alt = $self->_parseBit($1);
259 defined $alt or return 0 ;
260 $out .= "($alt)" ;
261
262 ++ $self->{Braces} ;
263 }
264 }
265
266 return _unmatched "("
267 if $depth ;
268
269 $out .= quotemeta $string ;
270
271
272 $self->{InputGlob} =~ s/$noPreBS[\(\)]//g;
273 $self->{InputPattern} = $out ;
274
275 #print "# INPUT '$self->{InputGlob}' => '$out'\n";
276
277 return 1 ;
278
279}
280
281sub _parseOutputGlob
282{
283 my $self = shift ;
284
285 my $string = $self->{OutputGlob} ;
286 my $maxwild = $self->{WildCount};
287
288 if ($self->{GlobFlags} & GLOB_TILDE)
289 #if (1)
290 {
291 $string =~ s{
292 ^ ~ # find a leading tilde
293 ( # save this in $1
294 [^/] # a non-slash character
295 * # repeated 0 or more times (0 means me)
296 )
297 }{
298 $1
299 ? (getpwnam($1))[7]
300 : ( $ENV{HOME} || $ENV{LOGDIR} )
301 }ex;
302
303 }
304
305 # max #1 must be == to max no of '*' in input
306 while ( $string =~ m/#(\d)/g )
307 {
308 croak "Max wild is #$maxwild, you tried #$1"
309 if $1 > $maxwild ;
310 }
311
312 my $noPreBS = '(?<!\\\)' ; # no preceeding backslash
313 #warn "noPreBS = '$noPreBS'\n";
314
315 #$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
316 $string =~ s/${noPreBS}#(\d)/\${$1}/g;
317 $string =~ s#${noPreBS}\*#\${inFile}#g;
318 $string = '"' . $string . '"';
319
320 #print "OUTPUT '$self->{OutputGlob}' => '$string'\n";
321 $self->{OutputPattern} = $string ;
322
323 return 1 ;
324}
325
326sub _getFiles
327{
328 my $self = shift ;
329
330 my %outInMapping = ();
331 my %inFiles = () ;
332
333 foreach my $inFile (@{ $self->{InputFiles} })
334 {
335 next if $inFiles{$inFile} ++ ;
336
337 my $outFile = $inFile ;
338
339 if ( $inFile =~ m/$self->{InputPattern}/ )
340 {
3413234µs265µs
# spent 40µs (16+25) within File::GlobMapper::BEGIN@341 which was called: # once (16µs+25µs) by IO::Compress::Base::Common::BEGIN@9 at line 341
no warnings 'uninitialized';
# spent 40µs making 1 call to File::GlobMapper::BEGIN@341 # spent 25µs making 1 call to warnings::unimport
342 eval "\$outFile = $self->{OutputPattern};" ;
343
344 if (defined $outInMapping{$outFile})
345 {
346 $Error = "multiple input files map to one output file";
347 return undef ;
348 }
349 $outInMapping{$outFile} = $inFile;
350 push @{ $self->{Pairs} }, [$inFile, $outFile];
351 }
352 }
353
354 return 1 ;
355}
356
357sub getFileMap
358{
359 my $self = shift ;
360
361 return $self->{Pairs} ;
362}
363
364sub getHash
365{
366 my $self = shift ;
367
368 return { map { $_->[0] => $_->[1] } @{ $self->{Pairs} } } ;
369}
370
371154µs1;
372
373__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.