← Index
NYTProf Performance Profile   « block view • line view • sub view »
For bin/hailo
  Run on Thu Oct 21 22:50:37 2010
Reported on Thu Oct 21 22:52:05 2010

Filename/home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/site_perl/5.13.5/Term/Sk.pm
StatementsExecuted 325021 statements in 836ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
2500011356ms635msTerm::Sk::::show_maybeTerm::Sk::show_maybe
2500011229ms864msTerm::Sk::::upTerm::Sk::up
71531139ms211msTerm::Sk::::showTerm::Sk::show
7151119.0ms22.0msTerm::Sk::::CORE:printTerm::Sk::CORE:print (opcode)
14262112.4ms50.2msTerm::Sk::::commifyTerm::Sk::commify
111810µs1.94msTerm::Sk::::BEGIN@7Term::Sk::BEGIN@7
111573µs1.53msTerm::Sk::::BEGIN@6Term::Sk::BEGIN@6
111253µs597µsTerm::Sk::::newTerm::Sk::new
163141µs41µsTerm::Sk::::CORE:matchTerm::Sk::CORE:match (opcode)
11130µs35µsTerm::Sk::::BEGIN@3Term::Sk::BEGIN@3
22220µs75µsTerm::Sk::::closeTerm::Sk::close
11112µs27µsTerm::Sk::::BEGIN@4Term::Sk::BEGIN@4
11110µs40µsTerm::Sk::::DESTROYTerm::Sk::DESTROY
0000s0sTerm::Sk::::downTerm::Sk::down
0000s0sTerm::Sk::::get_lineTerm::Sk::get_line
0000s0sTerm::Sk::::log_infoTerm::Sk::log_info
0000s0sTerm::Sk::::rem_backspaceTerm::Sk::rem_backspace
0000s0sTerm::Sk::::set_bkup_sizeTerm::Sk::set_bkup_size
0000s0sTerm::Sk::::set_chunk_sizeTerm::Sk::set_chunk_size
0000s0sTerm::Sk::::ticksTerm::Sk::ticks
0000s0sTerm::Sk::::whisperTerm::Sk::whisper
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Term::Sk;
2
3246µs241µ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
use strict;
# spent 35µs making 1 call to Term::Sk::BEGIN@3 # spent 6µs making 1 call to strict::import
4232µs241µ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
use warnings;
# spent 27µs making 1 call to Term::Sk::BEGIN@4 # spent 14µs making 1 call to warnings::import
5
62147µs21.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
use Time::HiRes qw( time );
# spent 1.53ms making 1 call to Term::Sk::BEGIN@6 # spent 353µs making 1 call to Time::HiRes::import
721.80ms22.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
use Fcntl qw(:seek);
# spent 1.94ms making 1 call to Term::Sk::BEGIN@7 # spent 796µs making 1 call to Exporter::import
8
912µsrequire Exporter;
10
1115µsour @ISA = qw(Exporter);
12
1312µsour %EXPORT_TAGS = ( 'all' => [ qw(set_chunk_size set_bkup_size rem_backspace) ] );
14
1513µsour @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
16
1711µsour @EXPORT = qw();
18
1911µsour $VERSION = '0.06';
20
2111µsour $errcode = 0;
2211µsour $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
sub new {
25106308µ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 if ($hash{num} eq '9') {
54 $self->{sep} = '';
55 $self->{group} = 0;
56 }
57 else {
5816µ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 '') {
73819µ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);
75715µ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;
112114µ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
1151289µs $self->show;
# spent 289µs making 1 call to Term::Sk::show
116
117 return $self;
118}
119
120sub 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
139sub get_line {
140 my $self = shift;
141
142 return $self->{line};
143}
144
14575000217ms25000635ms
# 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
sub up { my $self = shift; $self->{value} += defined $_[0] ? $_[0] : 1; $self->show_maybe; }
# spent 635ms making 25000 calls to Term::Sk::show_maybe, avg 25µs/call
146sub down { my $self = shift; $self->{value} -= defined $_[0] ? $_[0] : 1; $self->show_maybe; }
147620µs255µ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
sub close { my $self = shift; $self->{value} = undef; $self->show; }
# spent 55µs making 2 calls to Term::Sk::show, avg 28µs/call
148
149sub 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
sub DESTROY {
152210µs my $self = shift;
153129µ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
sub show_maybe {
157175000443ms my $self = shift;
158
159 $self->{line} = '';
160
1612500068.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
167712210ms 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
# spent 211ms (139+72.2) within Term::Sk::show which was called 715 times, avg 295µs/call: # 712 times (138ms+72.1ms) by Term::Sk::show_maybe at line 167, avg 296µs/call # 2 times (42µs+13µs) by Term::Sk::close at line 147, avg 28µs/call # once (192µs+97µs) by Term::Sk::new at line 115
sub show {
18572035161ms 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 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 my ($type, $lit, $len) = ($act->{type}, $act->{lit}, $act->{len});
198
199 if ($type eq '*lit') { # print (= append to $text) a simple literal
200 $text .= $lit;
201 next;
202 }
203 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 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 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 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 if ($type eq 'c') { # print (= append to $text) actual counter value (commified)
23571329.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 if ($type eq 'm') { # print (= append to $text) target (commified)
23971320.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 unless ($self->{test} or $self->{quiet}) {
251 local $| = 1;
252142924.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
# spent 50.2ms (12.4+37.9) within Term::Sk::commify which was called 1426 times, avg 35µs/call: # 713 times (7.10ms+22.7ms) by Term::Sk::show at line 235, avg 42µs/call # 713 times (5.27ms+15.1ms) by Term::Sk::show at line 239, avg 29µs/call
sub commify {
259285212.7ms my $com = shift;
260142637.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
2741800nsmy $log_info = '';
275
276sub log_info { $log_info }
277
27811µsmy $chunk_size = 10000;
2791700nsmy $bkup_size = 80;
280
281sub set_chunk_size { $chunk_size = $_[0]; if ($chunk_size < 100) { $chunk_size = 100;} }
282sub set_bkup_size { $bkup_size = $_[0]; if ($bkup_size < 10) { $bkup_size = 10;} }
283
284sub 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
35018µs1;
351__END__
 
# spent 41µs within Term::Sk::CORE:match which was called 16 times, avg 3µs/call: # 8 times (19µs+0s) by Term::Sk::new at line 73, avg 2µs/call # 7 times (15µs+0s) by Term::Sk::new at line 75, avg 2µs/call # once (6µs+0s) by Term::Sk::new at line 58
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
sub Term::Sk::CORE:print; # opcode