← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:47 2015

Filename/usr/share/perl5/String/Random.pm
StatementsExecuted 25 statements in 1.72ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11112µs24µsString::Random::::BEGIN@17String::Random::BEGIN@17
1118µs15µsString::Random::::BEGIN@18String::Random::BEGIN@18
1117µs34µsString::Random::::BEGIN@20String::Random::BEGIN@20
1113µs3µsString::Random::::BEGIN@21String::Random::BEGIN@21
0000s0sString::Random::::__ANON__[:100]String::Random::__ANON__[:100]
0000s0sString::Random::::__ANON__[:104]String::Random::__ANON__[:104]
0000s0sString::Random::::__ANON__[:122]String::Random::__ANON__[:122]
0000s0sString::Random::::__ANON__[:126]String::Random::__ANON__[:126]
0000s0sString::Random::::__ANON__[:130]String::Random::__ANON__[:130]
0000s0sString::Random::::__ANON__[:134]String::Random::__ANON__[:134]
0000s0sString::Random::::__ANON__[:176]String::Random::__ANON__[:176]
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
15111µsrequire 5.006_001;
16
17223µs236µs
# spent 24µs (12+12) within String::Random::BEGIN@17 which was called: # once (12µs+12µs) by C4::Members::BEGIN@27 at line 17
use strict;
# spent 24µs making 1 call to String::Random::BEGIN@17 # spent 12µs making 1 call to strict::import
18220µs223µs
# spent 15µs (8+8) within String::Random::BEGIN@18 which was called: # once (8µs+8µs) by C4::Members::BEGIN@27 at line 18
use warnings;
# spent 15µs making 1 call to String::Random::BEGIN@18 # spent 8µs making 1 call to warnings::import
19
20221µs262µs
# spent 34µs (7+28) within String::Random::BEGIN@20 which was called: # once (7µs+28µs) by C4::Members::BEGIN@27 at line 20
use Carp;
# spent 34µs making 1 call to String::Random::BEGIN@20 # spent 28µs making 1 call to Exporter::import
2121.42ms13µs
# spent 3µs within String::Random::BEGIN@21 which was called: # once (3µs+0s) by C4::Members::BEGIN@27 at line 21
use Exporter ();
# spent 3µs making 1 call to String::Random::BEGIN@21
22
2316µsour @ISA = qw(Exporter);
2411µsour %EXPORT_TAGS = ( 'all' => [ qw(
25 &random_string
26 &random_regex
27) ] );
281800nsour @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
291200nsour @EXPORT = ();
301200nsour $VERSION = '0.26';
31
32# These are the various character sets.
3312µsour @upper=("A".."Z");
3412µsour @lower=("a".."z");
351900nsour @digit=("0".."9");
36111µsour @punct=map { chr($_); } (33..47,58..64,91..96,123..126);
3717µsour @any=(@upper, @lower, @digit, @punct);
3816µsour @salt=(@upper, @lower, @digit, ".", "/");
39169µ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.
43147µ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, "_" ],
60144µ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 }
91 else {
92 if ($tmp =~ /\w/) {
93 carp "'\\$tmp' being treated as literal '$tmp'";
94 }
95 push(@{$string}, [$tmp]);
96 }
97 } else {
98 croak "regex not terminated";
99 }
100 },
101 '.' => sub {
102 my ($self, $ch, $chars, $string)=@_;
103 push(@{$string}, $patterns{$ch});
104 },
105 '[' => sub {
106 my ($self, $ch, $chars, $string)=@_;
107 my @tmp;
108 while (defined($ch=shift(@{$chars})) && ($ch ne "]")) {
109 if (($ch eq "-") && @{$chars} && @tmp) {
110 $ch=shift(@{$chars});
111 for (my $n=ord($tmp[$#tmp]);$n<ord($ch);$n++) {
112 push(@tmp, chr($n+1));
113 }
114 } else {
115 carp "'$ch' will be treated literally inside []"
116 if ($ch=~/\W/);
117 push(@tmp, $ch);
118 }
119 }
120 croak "unmatched []" if ($ch ne "]");
121 push(@{$string}, \@tmp);
122 },
123 '*' => sub {
124 my ($self, $ch, $chars, $string)=@_;
125 unshift(@{$chars}, split("", "{0,}"));
126 },
127 '+' => sub {
128 my ($self, $ch, $chars, $string)=@_;
129 unshift(@{$chars}, split("", "{1,}"));
130 },
131 '?' => sub {
132 my ($self, $ch, $chars, $string)=@_;
133 unshift(@{$chars}, split("", "{0,1}"));
134 },
135 '{' => sub {
136 my ($self, $ch, $chars, $string)=@_;
137 my ($n, $closed);
138 for ($n=0;$n<scalar(@{$chars});$n++) {
139 if ($chars->[$n] eq "}") {
140 $closed++;
141 last;
142 }
143 }
144 if ($closed) {
145 my $tmp;
146 while (defined($ch=shift(@{$chars})) && ($ch ne "}")) {
147 croak "'$ch' inside {} not supported" if ($ch!~/[\d,]/);
148 $tmp.=$ch;
149 }
150 if ($tmp=~/,/) {
151 if (my ($min,$max) = $tmp =~ /^(\d*),(\d*)$/) {
152 $min = 0 if (!length($min));
153 $max = $self->{'_max'} if (!length($max));
154 croak "bad range {$tmp}" if ($min>$max);
155 if ($min == $max) {
156 $tmp = $min;
157 } else {
158 $tmp = $min + int(rand($max - $min +1));
159 }
160 } else {
161 croak "malformed range {$tmp}";
162 }
163 }
164 if ($tmp) {
165 my $last=$string->[$#{$string}];
166 for ($n=0;$n<($tmp-1);$n++) {
167 push(@{$string}, $last);
168 }
169 } else {
170 pop(@{$string});
171 }
172 } else {
173 # { isn't closed, so treat it literally.
174 push(@{$string}, [$ch]);
175 }
176 },
177113µs);
178
179sub new {
180 my $proto=shift;
181 my $class=ref($proto) || $proto;
182 my $self;
183 $self={ %old_patterns }; # makes $self refer to a copy of %old_patterns
184 my %args=();
185 %args=@_ if (@_);
186 if (defined($args{'max'})) {
187 $self->{'_max'}=$args{'max'};
188 } else {
189 $self->{'_max'}=10;
190 }
191 return bless($self, $class);
192}
193
194# Returns a random string for each regular expression given as an
195# argument, or the strings concatenated when used in a scalar context.
196sub randregex {
197 my $self=shift;
198 croak "called without a reference" if (!ref($self));
199
200 my @strings=();
201
202 while (defined(my $pattern=shift)) {
203 my $ch;
204 my @string=();
205 my $string='';
206
207 # Split the characters in the pattern
208 # up into a list for easier parsing.
209 my @chars=split(//, $pattern);
210
211 while (defined($ch=shift(@chars))) {
212 if (defined($regch{$ch})) {
213 $regch{$ch}->($self, $ch, \@chars, \@string);
214 } elsif ($ch=~/[\$\^\*\(\)\+\{\}\]\|\?]/) {
215 # At least some of these probably should have special meaning.
216 carp "'$ch' not implemented. treating literally.";
217 push(@string, [$ch]);
218 } else {
219 push(@string, [$ch]);
220 }
221 }
222
223 foreach $ch (@string) {
224 $string.=$ch->[int(rand(scalar(@{$ch})))];
225 }
226
227 push(@strings, $string);
228 }
229
230 return wantarray ? @strings : join("", @strings);
231}
232
233# For compatibility with an ancient version, please ignore...
234sub from_pattern {
235 my $self=shift;
236 croak "called without a reference" if (!ref($self));
237
238 return $self->randpattern(@_);
239}
240
241sub randpattern {
242 my $self=shift;
243 croak "called without a reference" if (!ref($self));
244
245 my @strings=();
246
247 while (defined(my $pattern=shift)) {
248 my $string='';
249
250 for my $ch (split(//, $pattern)) {
251 if (defined($self->{$ch})) {
252 $string.=$self->{$ch}->[int(rand(scalar(@{$self->{$ch}})))];
253 } else {
254 croak qq(Unknown pattern character "$ch"!);
255 }
256 }
257 push(@strings, $string);
258 }
259
260 return wantarray ? @strings : join("", @strings);
261}
262
263sub random_regex {
264 my $foo=new String::Random;
265 return $foo->randregex(@_);
266}
267
268sub random_string {
269 my($pattern,@list)=@_;
270
271 my($n,$foo);
272
273 $foo=new String::Random;
274
275 for ($n=0;$n<=$#list;$n++) {
276 @{$foo->{$n}}=@{$list[$n]};
277 }
278
279 return $foo->randpattern($pattern);
280}
281
282115µs1;
283__END__
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.