← 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:32 2013

Filename/usr/share/perl5/String/Random.pm
StatementsExecuted 29 statements in 2.60ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11117µs21µsString::Random::::BEGIN@17String::Random::BEGIN@17
11113µs39µsString::Random::::BEGIN@18String::Random::BEGIN@18
11112µs61µsString::Random::::BEGIN@20String::Random::BEGIN@20
1115µs5µsString::Random::::BEGIN@21String::Random::BEGIN@21
0000s0sString::Random::::__ANON__[:101]String::Random::__ANON__[:101]
0000s0sString::Random::::__ANON__[:119]String::Random::__ANON__[:119]
0000s0sString::Random::::__ANON__[:123]String::Random::__ANON__[:123]
0000s0sString::Random::::__ANON__[:127]String::Random::__ANON__[:127]
0000s0sString::Random::::__ANON__[:131]String::Random::__ANON__[:131]
0000s0sString::Random::::__ANON__[:173]String::Random::__ANON__[:173]
0000s0sString::Random::::__ANON__[:97]String::Random::__ANON__[:97]
0000s0sString::Random::::from_patternString::Random::from_pattern
0000s0sString::Random::::newString::Random::new
0000s0sString::Random::::random_regexString::Random::random_regex
0000s0sString::Random::::random_stringString::Random::random_string
0000s0sString::Random::::randpatternString::Random::randpattern
0000s0sString::Random::::randregexString::Random::randregex
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1# String::Random - Generates a random string from a pattern
2# Copyright (C) 1999-2006 Steven Pritchard <steve@silug.org>
3#
4# This program is free software; you can redistribute it
5# and/or modify it under the same terms as Perl itself.
6#
7# This program is distributed in the hope that it will be useful,
8# but WITHOUT ANY WARRANTY; without even the implied warranty of
9# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
10#
11# $Id: Random.pm,v 1.4 2006/09/21 17:34:07 steve Exp $
12
13package String::Random;
14
15128µsrequire 5.006_001;
16
17328µs225µs
# spent 21µs (17+4) within String::Random::BEGIN@17 which was called: # once (17µs+4µs) by C4::Members::BEGIN@28 at line 17
use strict;
# spent 21µs making 1 call to String::Random::BEGIN@17 # spent 4µs making 1 call to strict::import
18331µs266µs
# spent 39µs (13+27) within String::Random::BEGIN@18 which was called: # once (13µs+27µs) by C4::Members::BEGIN@28 at line 18
use warnings;
# spent 39µs making 1 call to String::Random::BEGIN@18 # spent 27µs making 1 call to warnings::import
19
20329µs2110µs
# spent 61µs (12+49) within String::Random::BEGIN@20 which was called: # once (12µs+49µs) by C4::Members::BEGIN@28 at line 20
use Carp;
# spent 61µs making 1 call to String::Random::BEGIN@20 # spent 49µs making 1 call to Exporter::import
2132.01ms15µs
# spent 5µs within String::Random::BEGIN@21 which was called: # once (5µs+0s) by C4::Members::BEGIN@28 at line 21
use Exporter ();
# spent 5µs making 1 call to String::Random::BEGIN@21
22
23113µsour @ISA = qw(Exporter);
2413µsour %EXPORT_TAGS = ( 'all' => [ qw(
25 &random_string
26 &random_regex
27) ] );
2813µsour @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
291500nsour @EXPORT = ();
301700nsour $VERSION = '0.22';
31
32# These are the various character sets.
33111µsour @upper=("A".."Z");
34110µsour @lower=("a".."z");
3513µsour @digit=("0".."9");
36121µsour @punct=map { chr($_); } (33..47,58..64,91..96,123..126);
37110µsour @any=(@upper, @lower, @digit, @punct);
38111µsour @salt=(@upper, @lower, @digit, ".", "/");
391137µsour @binary=map { chr($_) } (0..255);
40
41# What's important is how they relate to the pattern characters.
42# These are the old patterns for randpattern/random_string.
43158µsour %old_patterns = (
44 'C' => [ @upper ],
45 'c' => [ @lower ],
46 'n' => [ @digit ],
47 '!' => [ @punct ],
48 '.' => [ @any ],
49 's' => [ @salt ],
50 'b' => [ @binary ],
51);
52
53# These are the regex-based patterns.
54our %patterns = (
55 # These are the regex-equivalents.
56 '.' => [ @any ],
57 '\d' => [ @digit ],
58 '\D' => [ @upper, @lower, @punct ],
59 '\w' => [ @upper, @lower, @digit, "_" ],
60169µs '\W' => [ grep { $_ ne "_" } @punct ],
61 '\s' => [ " ", "\t" ], # Would anything else make sense?
62 '\S' => [ @upper, @lower, @digit, @punct ],
63
64 # These are translated to their double quoted equivalents.
65 '\t' => [ "\t" ],
66 '\n' => [ "\n" ],
67 '\r' => [ "\r" ],
68 '\f' => [ "\f" ],
69 '\a' => [ "\a" ],
70 '\e' => [ "\e" ],
71);
72
73# These characters are treated specially in randregex().
74our %regch = (
75 "\\" => sub {
76 my ($self, $ch, $chars, $string)=@_;
77 if (@{$chars}) {
78 my $tmp=shift(@{$chars});
79 if ($tmp eq "x") {
80 # This is supposed to be a number in hex, so
81 # there had better be at least 2 characters left.
82 $tmp=shift(@{$chars}) . shift(@{$chars});
83 push(@{$string}, [chr(hex($tmp))]);
84 } elsif ($tmp=~/[0-7]/) {
85 carp "octal parsing not implemented. treating literally.";
86 push(@{$string}, [$tmp]);
87 } elsif (defined($patterns{"\\$tmp"})) {
88 $ch.=$tmp;
89 push(@{$string}, $patterns{$ch});
90 } else {
91 carp "'\\$tmp' being treated as literal '$tmp'";
92 push(@{$string}, [$tmp]);
93 }
94 } else {
95 croak "regex not terminated";
96 }
97 },
98 '.' => sub {
99 my ($self, $ch, $chars, $string)=@_;
100 push(@{$string}, $patterns{$ch});
101 },
102 '[' => sub {
103 my ($self, $ch, $chars, $string)=@_;
104 my @tmp;
105 while (defined($ch=shift(@{$chars})) && ($ch ne "]")) {
106 if (($ch eq "-") && @{$chars} && @tmp) {
107 $ch=shift(@{$chars});
108 for (my $n=ord($tmp[$#tmp]);$n<ord($ch);$n++) {
109 push(@tmp, chr($n+1));
110 }
111 } else {
112 carp "'$ch' will be treated literally inside []"
113 if ($ch=~/\W/);
114 push(@tmp, $ch);
115 }
116 }
117 croak "unmatched []" if ($ch ne "]");
118 push(@{$string}, \@tmp);
119 },
120 '*' => sub {
121 my ($self, $ch, $chars, $string)=@_;
122 unshift(@{$chars}, split("", "{0,}"));
123 },
124 '+' => sub {
125 my ($self, $ch, $chars, $string)=@_;
126 unshift(@{$chars}, split("", "{1,}"));
127 },
128 '?' => sub {
129 my ($self, $ch, $chars, $string)=@_;
130 unshift(@{$chars}, split("", "{0,1}"));
131 },
132 '{' => sub {
133 my ($self, $ch, $chars, $string)=@_;
134 my ($n, $closed);
135 for ($n=0;$n<scalar(@{$chars});$n++) {
136 if ($chars->[$n] eq "}") {
137 $closed++;
138 last;
139 }
140 }
141 if ($closed) {
142 my $tmp;
143 while (defined($ch=shift(@{$chars})) && ($ch ne "}")) {
144 croak "'$ch' inside {} not supported" if ($ch!~/[\d,]/);
145 $tmp.=$ch;
146 }
147 if ($tmp=~/,/) {
148 if (my ($min,$max) = $tmp =~ /^(\d*),(\d*)$/) {
149 $min = 0 if (!length($min));
150 $max = $self->{'_max'} if (!length($max));
151 croak "bad range {$tmp}" if ($min>$max);
152 if ($min == $max) {
153 $tmp = $min;
154 } else {
155 $tmp = $min + int(rand($max - $min +1));
156 }
157 } else {
158 croak "malformed range {$tmp}";
159 }
160 }
161 if ($tmp) {
162 my $last=$string->[$#{$string}];
163 for ($n=0;$n<($tmp-1);$n++) {
164 push(@{$string}, $last);
165 }
166 } else {
167 pop(@{$string});
168 }
169 } else {
170 # { isn't closed, so treat it literally.
171 push(@{$string}, [$ch]);
172 }
173 },
174147µs);
175
176sub new {
177 my $proto=shift;
178 my $class=ref($proto) || $proto;
179 my $self;
180 $self={ %old_patterns }; # makes $self refer to a copy of %old_patterns
181 my %args=();
182 %args=@_ if (@_);
183 if (defined($args{'max'})) {
184 $self->{'_max'}=$args{'max'};
185 } else {
186 $self->{'_max'}=10;
187 }
188 return bless($self, $class);
189}
190
191# Returns a random string for each regular expression given as an
192# argument, or the strings concatenated when used in a scalar context.
193sub randregex {
194 my $self=shift;
195 croak "called without a reference" if (!ref($self));
196
197 my @strings=();
198
199 while (defined(my $pattern=shift)) {
200 my $ch;
201 my @string=();
202 my $string='';
203
204 # Split the characters in the pattern
205 # up into a list for easier parsing.
206 my @chars=split(//, $pattern);
207
208 while (defined($ch=shift(@chars))) {
209 if (defined($regch{$ch})) {
210 $regch{$ch}->($self, $ch, \@chars, \@string);
211 } elsif ($ch=~/[\$\^\*\(\)\+\{\}\]\|\?]/) {
212 # At least some of these probably should have special meaning.
213 carp "'$ch' not implemented. treating literally.";
214 push(@string, [$ch]);
215 } else {
216 push(@string, [$ch]);
217 }
218 }
219
220 foreach $ch (@string) {
221 $string.=$ch->[int(rand(scalar(@{$ch})))];
222 }
223
224 push(@strings, $string);
225 }
226
227 return wantarray ? @strings : join("", @strings);
228}
229
230# For compatibility with an ancient version, please ignore...
231sub from_pattern {
232 my $self=shift;
233 croak "called without a reference" if (!ref($self));
234
235 return $self->randpattern(@_);
236}
237
238sub randpattern {
239 my $self=shift;
240 croak "called without a reference" if (!ref($self));
241
242 my @strings=();
243
244 while (defined(my $pattern=shift)) {
245 my $string='';
246
247 for my $ch (split(//, $pattern)) {
248 if (defined($self->{$ch})) {
249 $string.=$self->{$ch}->[int(rand(scalar(@{$self->{$ch}})))];
250 } else {
251 croak qq(Unknown pattern character "$ch"!);
252 }
253 }
254 push(@strings, $string);
255 }
256
257 return wantarray ? @strings : join("", @strings);
258}
259
260sub random_regex {
261 my $foo=new String::Random;
262 return $foo->randregex(@_);
263}
264
265sub random_string {
266 my($pattern,@list)=@_;
267
268 my($n,$foo);
269
270 $foo=new String::Random;
271
272 for ($n=0;$n<=$#list;$n++) {
273 @{$foo->{$n}}=@{$list[$n]};
274 }
275
276 return $foo->randpattern($pattern);
277}
278
279180µs1;
280__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.