Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/site_perl/5.13.5/Term/Sk.pm |
Statements | Executed 325021 statements in 836ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
25000 | 1 | 1 | 356ms | 635ms | show_maybe | Term::Sk::
25000 | 1 | 1 | 229ms | 864ms | up | Term::Sk::
715 | 3 | 1 | 139ms | 211ms | show | Term::Sk::
715 | 1 | 1 | 19.0ms | 22.0ms | CORE:print (opcode) | Term::Sk::
1426 | 2 | 1 | 12.4ms | 50.2ms | commify | Term::Sk::
1 | 1 | 1 | 810µs | 1.94ms | BEGIN@7 | Term::Sk::
1 | 1 | 1 | 573µs | 1.53ms | BEGIN@6 | Term::Sk::
1 | 1 | 1 | 253µs | 597µs | new | Term::Sk::
16 | 3 | 1 | 41µs | 41µs | CORE:match (opcode) | Term::Sk::
1 | 1 | 1 | 30µs | 35µs | BEGIN@3 | Term::Sk::
2 | 2 | 2 | 20µs | 75µs | close | Term::Sk::
1 | 1 | 1 | 12µs | 27µs | BEGIN@4 | Term::Sk::
1 | 1 | 1 | 10µs | 40µs | DESTROY | Term::Sk::
0 | 0 | 0 | 0s | 0s | down | Term::Sk::
0 | 0 | 0 | 0s | 0s | get_line | Term::Sk::
0 | 0 | 0 | 0s | 0s | log_info | Term::Sk::
0 | 0 | 0 | 0s | 0s | rem_backspace | Term::Sk::
0 | 0 | 0 | 0s | 0s | set_bkup_size | Term::Sk::
0 | 0 | 0 | 0s | 0s | set_chunk_size | Term::Sk::
0 | 0 | 0 | 0s | 0s | ticks | Term::Sk::
0 | 0 | 0 | 0s | 0s | whisper | Term::Sk::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Term::Sk; | ||||
2 | |||||
3 | 2 | 46µs | 2 | 41µs | # spent 35µs (30+6) within Term::Sk::BEGIN@3 which was called:
# once (30µs+6µs) by Hailo::Command::__ANON__[lib/Hailo/Command.pm:307] at line 3 # spent 35µs making 1 call to Term::Sk::BEGIN@3
# spent 6µs making 1 call to strict::import |
4 | 2 | 32µs | 2 | 41µs | # spent 27µs (12+14) within Term::Sk::BEGIN@4 which was called:
# once (12µs+14µs) by Hailo::Command::__ANON__[lib/Hailo/Command.pm:307] at line 4 # spent 27µs making 1 call to Term::Sk::BEGIN@4
# spent 14µs making 1 call to warnings::import |
5 | |||||
6 | 2 | 147µs | 2 | 1.89ms | # spent 1.53ms (573µs+961µs) within Term::Sk::BEGIN@6 which was called:
# once (573µs+961µs) by Hailo::Command::__ANON__[lib/Hailo/Command.pm:307] at line 6 # spent 1.53ms making 1 call to Term::Sk::BEGIN@6
# spent 353µs making 1 call to Time::HiRes::import |
7 | 2 | 1.80ms | 2 | 2.74ms | # spent 1.94ms (810µs+1.13) within Term::Sk::BEGIN@7 which was called:
# once (810µs+1.13ms) by Hailo::Command::__ANON__[lib/Hailo/Command.pm:307] at line 7 # spent 1.94ms making 1 call to Term::Sk::BEGIN@7
# spent 796µs making 1 call to Exporter::import |
8 | |||||
9 | 1 | 2µs | require Exporter; | ||
10 | |||||
11 | 1 | 5µs | our @ISA = qw(Exporter); | ||
12 | |||||
13 | 1 | 2µs | our %EXPORT_TAGS = ( 'all' => [ qw(set_chunk_size set_bkup_size rem_backspace) ] ); | ||
14 | |||||
15 | 1 | 3µs | our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); | ||
16 | |||||
17 | 1 | 1µs | our @EXPORT = qw(); | ||
18 | |||||
19 | 1 | 1µs | our $VERSION = '0.06'; | ||
20 | |||||
21 | 1 | 1µs | our $errcode = 0; | ||
22 | 1 | 1µs | our $errmsg = ''; | ||
23 | |||||
24 | # spent 597µs (253+345) within Term::Sk::new which was called:
# once (253µs+345µs) by Hailo::Command::train_progress at line 326 of lib/Hailo/Command.pm | ||||
25 | 30 | 89µs | shift; | ||
26 | my $self = {}; | ||||
27 | bless $self; | ||||
28 | |||||
29 | $errcode = 0; | ||||
30 | $errmsg = ''; | ||||
31 | |||||
32 | my %hash = (freq => 1, base => 0, target => 1_000, quiet => 0, test => 0, num => q{9_999}); | ||||
33 | %hash = (%hash, %{$_[1]}) if defined $_[1]; | ||||
34 | |||||
35 | my $format = defined $_[0] ? $_[0] : '%8c'; | ||||
36 | |||||
37 | $self->{base} = $hash{base}; | ||||
38 | $self->{target} = $hash{target}; | ||||
39 | $self->{quiet} = $hash{quiet}; | ||||
40 | $self->{test} = $hash{test}; | ||||
41 | $self->{format} = $format; | ||||
42 | $self->{freq} = $hash{freq}; | ||||
43 | $self->{value} = $hash{base}; | ||||
44 | $self->{oldtext} = ''; | ||||
45 | $self->{line} = ''; | ||||
46 | $self->{pdisp} = '#'; | ||||
47 | $self->{commify} = $hash{commify}; | ||||
48 | |||||
49 | unless (defined $self->{quiet}) { | ||||
50 | $self->{quiet} = !-t STDOUT; | ||||
51 | } | ||||
52 | |||||
53 | 3 | 18µs | if ($hash{num} eq '9') { | ||
54 | $self->{sep} = ''; | ||||
55 | $self->{group} = 0; | ||||
56 | } | ||||
57 | else { | ||||
58 | 1 | 6µs | my ($sep, $group) = $hash{num} =~ m{\A 9 ([^\d\+\-]) (9+) \z}xms or do {
# spent 6µs making 1 call to Term::Sk::CORE:match | ||
59 | $errcode = 95; | ||||
60 | $errmsg = qq{Can't parse num => '$hash{num}'}; | ||||
61 | die sprintf('Error-%04d: %s', $errcode, $errmsg); | ||||
62 | }; | ||||
63 | $self->{sep} = $sep; | ||||
64 | $self->{group} = length($group); | ||||
65 | } | ||||
66 | |||||
67 | # Here we de-compose the format into $self->{action} | ||||
68 | |||||
69 | $self->{action} = []; | ||||
70 | |||||
71 | my $fmt = $format; | ||||
72 | while ($fmt ne '') { | ||||
73 | 73 | 201µs | 8 | 19µs | if ($fmt =~ m{^ ([^%]*) % (.*) $}xms) {
# spent 19µs making 8 calls to Term::Sk::CORE:match, avg 2µs/call |
74 | my ($literal, $portion) = ($1, $2); | ||||
75 | 7 | 15µs | unless ($portion =~ m{^ (\d*) ([a-zA-Z]) (.*) $}xms) {
# spent 15µs making 7 calls to Term::Sk::CORE:match, avg 2µs/call | ||
76 | $errcode = 100; | ||||
77 | $errmsg = qq{Can't parse '%[<number>]<alpha>' from '%$portion', total line is '$format'}; | ||||
78 | die sprintf('Error-%04d: %s', $errcode, $errmsg); | ||||
79 | } | ||||
80 | |||||
81 | my ($repeat, $disp_code, $remainder) = ($1, $2, $3); | ||||
82 | |||||
83 | if ($repeat eq '') { $repeat = 1; } | ||||
84 | if ($repeat < 1) { $repeat = 1; } | ||||
85 | |||||
86 | unless ($disp_code eq 'b' | ||||
87 | or $disp_code eq 'c' | ||||
88 | or $disp_code eq 'd' | ||||
89 | or $disp_code eq 'm' | ||||
90 | or $disp_code eq 'p' | ||||
91 | or $disp_code eq 'P' | ||||
92 | or $disp_code eq 't') { | ||||
93 | $errcode = 110; | ||||
94 | $errmsg = qq{Found invalid display-code ('$disp_code'), expected ('b', 'c', 'd', 'm', 'p', 'P' or 't') in '%$portion', total line is '$format'}; | ||||
95 | die sprintf('Error-%04d: %s', $errcode, $errmsg); | ||||
96 | } | ||||
97 | |||||
98 | push @{$self->{action}}, {type => '*lit', len => length($literal), lit => $literal} if length($literal) > 0; | ||||
99 | push @{$self->{action}}, {type => $disp_code, len => $repeat}; | ||||
100 | $fmt = $remainder; | ||||
101 | } | ||||
102 | else { | ||||
103 | push @{$self->{action}}, {type => '*lit', len => length($fmt), lit => $fmt}; | ||||
104 | $fmt = ''; | ||||
105 | } | ||||
106 | } | ||||
107 | |||||
108 | # End of format de-composition | ||||
109 | |||||
110 | $self->{tick} = 0; | ||||
111 | $self->{out} = 0; | ||||
112 | 1 | 14µs | $self->{sec_begin} = int(time * 100);
# spent 14µs making 1 call to Time::HiRes::time | ||
113 | $self->{sec_print} = $self->{sec_begin}; | ||||
114 | |||||
115 | 1 | 289µs | $self->show;
# spent 289µs making 1 call to Term::Sk::show | ||
116 | |||||
117 | return $self; | ||||
118 | } | ||||
119 | |||||
120 | sub whisper { | ||||
121 | my $self = shift; | ||||
122 | |||||
123 | my $back = qq{\010} x length $self->{oldtext}; | ||||
124 | my $blank = q{ } x length $self->{oldtext}; | ||||
125 | |||||
126 | $self->{line} = join('', $back, $blank, $back, @_, $self->{oldtext}); | ||||
127 | |||||
128 | unless ($self->{test}) { | ||||
129 | local $| = 1; | ||||
130 | if ($self->{quiet}) { | ||||
131 | print @_; | ||||
132 | } | ||||
133 | else { | ||||
134 | print $self->{line}; | ||||
135 | } | ||||
136 | } | ||||
137 | } | ||||
138 | |||||
139 | sub get_line { | ||||
140 | my $self = shift; | ||||
141 | |||||
142 | return $self->{line}; | ||||
143 | } | ||||
144 | |||||
145 | 75000 | 217ms | 25000 | 635ms | # spent 864ms (229+635) within Term::Sk::up which was called 25000 times, avg 35µs/call:
# 25000 times (229ms+635ms) by Hailo::Command::train_progress at line 335 of lib/Hailo/Command.pm, avg 35µs/call # spent 635ms making 25000 calls to Term::Sk::show_maybe, avg 25µs/call |
146 | sub down { my $self = shift; $self->{value} -= defined $_[0] ? $_[0] : 1; $self->show_maybe; } | ||||
147 | 6 | 20µs | 2 | 55µs | # spent 75µs (20+55) within Term::Sk::close which was called 2 times, avg 38µs/call:
# once (12µs+34µs) by Hailo::Command::train_progress at line 338 of lib/Hailo/Command.pm
# once (8µs+21µs) by Term::Sk::DESTROY at line 153 # spent 55µs making 2 calls to Term::Sk::show, avg 28µs/call |
148 | |||||
149 | sub ticks { my $self = shift; return $self->{tick} } | ||||
150 | |||||
151 | # spent 40µs (10+29) within Term::Sk::DESTROY which was called:
# once (10µs+29µs) by Hailo::Command::train_progress at line 332 of Mouse/Meta/Class.pm | ||||
152 | 2 | 10µs | my $self = shift; | ||
153 | 1 | 29µs | $self->close;
# spent 29µs making 1 call to Term::Sk::close | ||
154 | } | ||||
155 | |||||
156 | # spent 635ms (356+279) within Term::Sk::show_maybe which was called 25000 times, avg 25µs/call:
# 25000 times (356ms+279ms) by Term::Sk::up at line 145, avg 25µs/call | ||||
157 | 175000 | 443ms | my $self = shift; | ||
158 | |||||
159 | $self->{line} = ''; | ||||
160 | |||||
161 | 25000 | 68.4ms | my $sec_now = int(time * 100);
# spent 68.4ms making 25000 calls to Time::HiRes::time, avg 3µs/call | ||
162 | my $sec_prev = $self->{sec_print}; | ||||
163 | |||||
164 | $self->{sec_print} = $sec_now; | ||||
165 | $self->{tick}++; | ||||
166 | |||||
167 | 712 | 210ms | if ($self->{freq} eq 's') {
# spent 210ms making 712 calls to Term::Sk::show, avg 296µs/call | ||
168 | if (int($sec_prev / 100) != int($sec_now / 100)) { | ||||
169 | $self->show; | ||||
170 | } | ||||
171 | } | ||||
172 | elsif ($self->{freq} eq 'd') { | ||||
173 | if (int($sec_prev / 10) != int($sec_now / 10)) { | ||||
174 | $self->show; | ||||
175 | } | ||||
176 | } | ||||
177 | else { | ||||
178 | unless ($self->{tick} % $self->{freq}) { | ||||
179 | $self->show; | ||||
180 | } | ||||
181 | } | ||||
182 | } | ||||
183 | |||||
184 | sub show { | ||||
185 | 6435 | 15.6ms | my $self = shift; | ||
186 | $self->{out}++; | ||||
187 | |||||
188 | my $back = qq{\010} x length $self->{oldtext}; | ||||
189 | my $blank = q{ } x length $self->{oldtext}; | ||||
190 | |||||
191 | my $text = ''; | ||||
192 | 713 | 2.45ms | if (defined $self->{value}) { | ||
193 | |||||
194 | # Here we compose a string based on $self->{action} (which, of course, is the previously de-composed format) | ||||
195 | |||||
196 | for my $act (@{$self->{action}}) { | ||||
197 | 37789 | 62.3ms | my ($type, $lit, $len) = ($act->{type}, $act->{lit}, $act->{len}); | ||
198 | |||||
199 | 9982 | 10.3ms | if ($type eq '*lit') { # print (= append to $text) a simple literal | ||
200 | $text .= $lit; | ||||
201 | next; | ||||
202 | } | ||||
203 | 4991 | 11.2ms | if ($type eq 't') { # print (= append to $text) time elapsed in format 'hh:mm:ss' | ||
204 | my $unit = int(($self->{sec_print} - $self->{sec_begin}) / 100); | ||||
205 | my $hour = int($unit / 3600); | ||||
206 | my $min = int(($unit % 3600) / 60); | ||||
207 | my $sec = $unit % 60; | ||||
208 | my $stamp = sprintf '%02d:%02d:%02d', $hour, $min, $sec; | ||||
209 | $text .= sprintf "%${len}.${len}s", $stamp; | ||||
210 | next; | ||||
211 | } | ||||
212 | 2852 | 6.24ms | if ($type eq 'd') { # print (= append to $text) a revolving dash in format '/-\|' | ||
213 | $text .= substr('/-\|', $self->{out} % 4, 1) x $len; | ||||
214 | next; | ||||
215 | } | ||||
216 | 2852 | 6.89ms | if ($type eq 'b') { # print (= append to $text) progress indicator format '#####_____' | ||
217 | my $progress = $self->{target} == $self->{base} ? 0 : | ||||
218 | int ($len * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base}) + 0.5); | ||||
219 | if ($progress < 0) { $progress = 0 } | ||||
220 | elsif ($progress > $len) { $progress = $len } | ||||
221 | $text .= $self->{pdisp} x $progress.'_' x ($len - $progress); | ||||
222 | next; | ||||
223 | } | ||||
224 | 2139 | 5.63ms | if ($type eq 'p') { # print (= append to $text) progress in percentage format '999%' | ||
225 | my $percent = $self->{target} == $self->{base} ? 0 : | ||||
226 | 100 * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base}); | ||||
227 | $text .= sprintf "%${len}.${len}s", sprintf("%.0f%%", $percent); | ||||
228 | next; | ||||
229 | } | ||||
230 | if ($type eq 'P') { # print (= append to $text) literally '%' characters | ||||
231 | $text .= '%' x $len; | ||||
232 | next; | ||||
233 | } | ||||
234 | 1426 | 5.96ms | if ($type eq 'c') { # print (= append to $text) actual counter value (commified) | ||
235 | 713 | 29.8ms | $text .= sprintf "%${len}s", commify($self->{commify}, $self->{value}, $self->{sep}, $self->{group});
# spent 29.8ms making 713 calls to Term::Sk::commify, avg 42µs/call | ||
236 | next; | ||||
237 | } | ||||
238 | 1426 | 5.12ms | if ($type eq 'm') { # print (= append to $text) target (commified) | ||
239 | 713 | 20.4ms | $text .= sprintf "%${len}s", commify($self->{commify}, $self->{target}, $self->{sep}, $self->{group});
# spent 20.4ms making 713 calls to Term::Sk::commify, avg 29µs/call | ||
240 | next; | ||||
241 | } | ||||
242 | # default: do nothing, in the (impossible) event that $type is none of '*lit', 't', 'b', 'p', 'P', 'c' or 'm' | ||||
243 | } | ||||
244 | |||||
245 | # End of string composition | ||||
246 | } | ||||
247 | |||||
248 | $self->{line} = join('', $back, $blank, $back, $text); | ||||
249 | |||||
250 | 1430 | 28.9ms | unless ($self->{test} or $self->{quiet}) { | ||
251 | local $| = 1; | ||||
252 | 1429 | 24.9ms | print $self->{line};
# spent 22.0ms making 715 calls to Term::Sk::CORE:print, avg 31µs/call
# spent 2.98ms making 714 calls to Encode::utf8::encode_xs, avg 4µs/call | ||
253 | } | ||||
254 | |||||
255 | $self->{oldtext} = $text; | ||||
256 | } | ||||
257 | |||||
258 | sub commify { | ||||
259 | 2852 | 12.7ms | my $com = shift; | ||
260 | 1426 | 37.9ms | if ($com) { return $com->($_[0]); }
# spent 37.9ms making 1426 calls to Hailo::Command::__ANON__[lib/Hailo/Command.pm:325], avg 27µs/call | ||
261 | |||||
262 | local $_ = shift; | ||||
263 | my ($sep, $group) = @_; | ||||
264 | |||||
265 | if ($group > 0) { | ||||
266 | my $len = length($_); | ||||
267 | for my $i (1..$len) { | ||||
268 | last unless s/^([-+]?\d+)(\d{$group})/$1$sep$2/; | ||||
269 | } | ||||
270 | } | ||||
271 | return $_; | ||||
272 | } | ||||
273 | |||||
274 | 1 | 800ns | my $log_info = ''; | ||
275 | |||||
276 | sub log_info { $log_info } | ||||
277 | |||||
278 | 1 | 1µs | my $chunk_size = 10000; | ||
279 | 1 | 700ns | my $bkup_size = 80; | ||
280 | |||||
281 | sub set_chunk_size { $chunk_size = $_[0]; if ($chunk_size < 100) { $chunk_size = 100;} } | ||||
282 | sub set_bkup_size { $bkup_size = $_[0]; if ($bkup_size < 10) { $bkup_size = 10;} } | ||||
283 | |||||
284 | sub rem_backspace { | ||||
285 | my ($fname) = @_; | ||||
286 | |||||
287 | open my $ifh, '<', $fname or die "Error-0200: Can't open < '$fname' because $!"; | ||||
288 | open my $tfh, '+>', undef or die "Error-0210: Can't open +> undef (tempfile) because $!"; | ||||
289 | |||||
290 | $log_info = ''; | ||||
291 | |||||
292 | my $out_buf = ''; | ||||
293 | |||||
294 | while (read($ifh, my $inp_buf, $chunk_size)) { | ||||
295 | $out_buf .= $inp_buf; | ||||
296 | my $log_input = length($inp_buf); | ||||
297 | |||||
298 | my $log_backspaces = 0; | ||||
299 | # here we are removing the backspaces: | ||||
300 | while ($out_buf =~ m{\010+}xms) { | ||||
301 | # $& is the same as substr($out_buf, $-[0], $+[0] - $-[0]) | ||||
302 | my ($pos_from, $pos_to) = ($-[0], $+[0]); | ||||
303 | $log_backspaces += $pos_to - $pos_from; | ||||
304 | |||||
305 | my ($underflow, $pos_left); | ||||
306 | if ($pos_from * 2 >= $pos_to) { | ||||
307 | $underflow = 0; | ||||
308 | $pos_left = $pos_from * 2 - $pos_to; | ||||
309 | } | ||||
310 | else { | ||||
311 | $underflow = 1; | ||||
312 | $pos_left = 0; | ||||
313 | } | ||||
314 | |||||
315 | my $delstr = substr($out_buf, $pos_left, $pos_from - $pos_left); | ||||
316 | |||||
317 | if ($underflow) { | ||||
318 | $log_info .= "[** Buffer underflow **]\n"; | ||||
319 | } | ||||
320 | if ($delstr =~ s{([[:cntrl:]])}{sprintf('[%02d]',ord($1))}xmsge) { | ||||
321 | $log_info .= "[** Ctlchar: '$delstr' **]\n"; | ||||
322 | } | ||||
323 | |||||
324 | $out_buf = substr($out_buf, 0, $pos_left).substr($out_buf, $pos_to); | ||||
325 | } | ||||
326 | |||||
327 | if (length($out_buf) > $bkup_size) { | ||||
328 | print {$tfh} substr($out_buf, 0, -$bkup_size); | ||||
329 | $out_buf = substr($out_buf, -$bkup_size); | ||||
330 | } | ||||
331 | |||||
332 | $log_info .= "[I=$log_input,B=$log_backspaces]"; | ||||
333 | } | ||||
334 | |||||
335 | CORE::close $ifh; # We need to employ CORE::close because there is already another close subroutine defined in the current namespace "Term::Sk" | ||||
336 | |||||
337 | print {$tfh} $out_buf; | ||||
338 | |||||
339 | # Now copy back temp-file to original file: | ||||
340 | |||||
341 | seek $tfh, 0, SEEK_SET or die "Error-0220: Can't seek tempfile to 0 because $!"; | ||||
342 | open my $ofh, '>', $fname or die "Error-0230: Can't open > '$fname' because $!"; | ||||
343 | |||||
344 | while (read($tfh, my $buf, $chunk_size)) { print {$ofh} $buf; } | ||||
345 | |||||
346 | CORE::close $ofh; | ||||
347 | CORE::close $tfh; | ||||
348 | } | ||||
349 | |||||
350 | 1 | 8µs | 1; | ||
351 | __END__ | ||||
sub Term::Sk::CORE:match; # opcode | |||||
# spent 22.0ms (19.0+2.98) within Term::Sk::CORE:print which was called 715 times, avg 31µs/call:
# 715 times (19.0ms+2.98ms) by Term::Sk::show at line 252, avg 31µs/call |