Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/5.13.5/open.pm |
Statements | Executed 52 statements in 8.92ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 5.95ms | 6.04ms | BEGIN@2 | open::
1 | 1 | 1 | 754µs | 12.2ms | BEGIN@88 | open::
1 | 1 | 1 | 202µs | 12.8ms | import | open::
3 | 3 | 1 | 85µs | 194µs | CORE:binmode (opcode) | open::
9 | 5 | 1 | 37µs | 37µs | CORE:match (opcode) | open::
2 | 2 | 1 | 37µs | 53µs | _drop_oldenc | open::
2 | 2 | 1 | 14µs | 14µs | CORE:subst (opcode) | open::
2 | 1 | 1 | 8µs | 8µs | CORE:substcont (opcode) | open::
0 | 0 | 0 | 0s | 0s | _get_encname | open::
0 | 0 | 0 | 0s | 0s | croak | open::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package open; | ||||
2 | 2 | 7.67ms | 2 | 6.07ms | # spent 6.04ms (5.95+89µs) within open::BEGIN@2 which was called:
# once (5.95ms+89µs) by hailo::BEGIN@4 at line 2 # spent 6.04ms making 1 call to open::BEGIN@2
# spent 29µs making 1 call to warnings::import |
3 | |||||
4 | 1 | 22µs | 1 | 12.2ms | our $VERSION = '1.08'; # spent 12.2ms making 1 call to open::BEGIN@88 |
5 | |||||
6 | 1 | 54µs | require 5.008001; # for PerlIO::get_layers() | ||
7 | |||||
8 | 1 | 2µs | my $locale_encoding; | ||
9 | |||||
10 | sub _get_encname { | ||||
11 | return ($1, Encode::resolve_alias($1)) if $_[0] =~ /^:?encoding\((.+)\)$/; | ||||
12 | return; | ||||
13 | } | ||||
14 | |||||
15 | sub croak { | ||||
16 | require Carp; goto &Carp::croak; | ||||
17 | } | ||||
18 | |||||
19 | sub _drop_oldenc { | ||||
20 | # If by the time we arrive here there already is at the top of the | ||||
21 | # perlio layer stack an encoding identical to what we would like | ||||
22 | # to push via this open pragma, we will pop away the old encoding | ||||
23 | # (+utf8) so that we can push ourselves in place (this is easier | ||||
24 | # than ignoring pushing ourselves because of the way how ${^OPEN} | ||||
25 | # works). So we are looking for something like | ||||
26 | # | ||||
27 | # stdio encoding(xxx) utf8 | ||||
28 | # | ||||
29 | # in the existing layer stack, and in the new stack chunk for | ||||
30 | # | ||||
31 | # :encoding(xxx) | ||||
32 | # | ||||
33 | # If we find a match, we pop the old stack (once, since | ||||
34 | # the utf8 is just a flag on the encoding layer) | ||||
35 | 8 | 54µs | my ($h, @new) = @_; | ||
36 | 2 | 6µs | return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/; # spent 6µs making 2 calls to open::CORE:match, avg 3µs/call | ||
37 | 2 | 10µs | my @old = PerlIO::get_layers($h); # spent 10µs making 2 calls to PerlIO::get_layers, avg 5µs/call | ||
38 | return unless @old >= 3 && | ||||
39 | $old[-1] eq 'utf8' && | ||||
40 | $old[-2] =~ /^encoding\(.+\)$/; | ||||
41 | require Encode; | ||||
42 | my ($loname, $lcname) = _get_encname($old[-2]); | ||||
43 | unless (defined $lcname) { # Should we trust get_layers()? | ||||
44 | croak("open: Unknown encoding '$loname'"); | ||||
45 | } | ||||
46 | my ($voname, $vcname) = _get_encname($new[-1]); | ||||
47 | unless (defined $vcname) { | ||||
48 | croak("open: Unknown encoding '$voname'"); | ||||
49 | } | ||||
50 | if ($lcname eq $vcname) { | ||||
51 | binmode($h, ":pop"); # utf8 is part of the encoding layer | ||||
52 | } | ||||
53 | } | ||||
54 | |||||
55 | # spent 12.8ms (202µs+12.6) within open::import which was called:
# once (202µs+12.6ms) by hailo::BEGIN@4 at line 4 of bin/hailo | ||||
56 | 36 | 325µs | my ($class,@args) = @_; | ||
57 | croak("open: needs explicit list of PerlIO layers") unless @args; | ||||
58 | my $std; | ||||
59 | my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); | ||||
60 | while (@args) { | ||||
61 | my $type = shift(@args); | ||||
62 | my $dscp; | ||||
63 | 2 | 15µs | if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) { # spent 15µs making 2 calls to open::CORE:match, avg 8µs/call | ||
64 | $type = 'IO'; | ||||
65 | $dscp = ":$1"; | ||||
66 | } elsif ($type eq ':std') { | ||||
67 | $std = 1; | ||||
68 | next; | ||||
69 | } else { | ||||
70 | $dscp = shift(@args) || ''; | ||||
71 | } | ||||
72 | my @val; | ||||
73 | foreach my $layer (split(/\s+/,$dscp)) { | ||||
74 | 1 | 6µs | $layer =~ s/^://; # spent 6µs making 1 call to open::CORE:subst | ||
75 | if ($layer eq 'locale') { | ||||
76 | require Encode; | ||||
77 | require encoding; | ||||
78 | $locale_encoding = encoding::_get_locale_encoding() | ||||
79 | unless defined $locale_encoding; | ||||
80 | (warnings::warnif("layer", "Cannot figure out an encoding to use"), last) | ||||
81 | unless defined $locale_encoding; | ||||
82 | $layer = "encoding($locale_encoding)"; | ||||
83 | $std = 1; | ||||
84 | } else { | ||||
85 | my $target = $layer; # the layer name itself | ||||
86 | 3 | 17µs | $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters # spent 8µs making 2 calls to open::CORE:substcont, avg 4µs/call
# spent 8µs making 1 call to open::CORE:subst | ||
87 | |||||
88 | 2 | 733µs | 2 | 23.7ms | # spent 12.2ms (754µs+11.4) within open::BEGIN@88 which was called:
# once (754µs+11.4ms) by PerlIO::Layer::find at line 4 # spent 12.3ms making 1 call to PerlIO::Layer::find
# spent 11.4ms making 1 call to PerlIO::import |
89 | warnings::warnif("layer", "Unknown PerlIO layer '$target'"); | ||||
90 | } | ||||
91 | } | ||||
92 | push(@val,":$layer"); | ||||
93 | 1 | 6µs | if ($layer =~ /^(crlf|raw)$/) { # spent 6µs making 1 call to open::CORE:match | ||
94 | $^H{"open_$type"} = $layer; | ||||
95 | } | ||||
96 | } | ||||
97 | if ($type eq 'IN') { | ||||
98 | _drop_oldenc(*STDIN, @val); | ||||
99 | $in = join(' ', @val); | ||||
100 | } | ||||
101 | elsif ($type eq 'OUT') { | ||||
102 | _drop_oldenc(*STDOUT, @val); | ||||
103 | $out = join(' ', @val); | ||||
104 | } | ||||
105 | elsif ($type eq 'IO') { | ||||
106 | 1 | 33µs | _drop_oldenc(*STDIN, @val); # spent 33µs making 1 call to open::_drop_oldenc | ||
107 | 1 | 20µs | _drop_oldenc(*STDOUT, @val); # spent 20µs making 1 call to open::_drop_oldenc | ||
108 | $in = $out = join(' ', @val); | ||||
109 | } | ||||
110 | else { | ||||
111 | croak "Unknown PerlIO layer class '$type' (need IN, OUT or IO)"; | ||||
112 | } | ||||
113 | } | ||||
114 | ${^OPEN} = join("\0", $in, $out); | ||||
115 | if ($std) { | ||||
116 | if ($in) { | ||||
117 | 1 | 22µs | 6 | 139µs | if ($in =~ /:utf8\b/) { # spent 89µs making 1 call to open::CORE:binmode
# spent 22µs making 1 call to Encode::find_encoding
# spent 19µs making 1 call to Encode::Encoding::renew
# spent 6µs making 2 calls to open::CORE:match, avg 3µs/call
# spent 3µs making 1 call to Encode::Encoding::needs_lines |
118 | binmode(STDIN, ":utf8"); | ||||
119 | } elsif ($in =~ /(\w+\(.+\))/) { | ||||
120 | binmode(STDIN, ":$1"); | ||||
121 | } | ||||
122 | } | ||||
123 | if ($out) { | ||||
124 | 2 | 4µs | if ($out =~ /:utf8\b/) { # spent 4µs making 2 calls to open::CORE:match, avg 2µs/call | ||
125 | binmode(STDOUT, ":utf8"); | ||||
126 | binmode(STDERR, ":utf8"); | ||||
127 | } elsif ($out =~ /(\w+\(.+\))/) { | ||||
128 | 1 | 13µs | 4 | 87µs | binmode(STDOUT, ":$1"); # spent 54µs making 1 call to open::CORE:binmode
# spent 15µs making 1 call to Encode::find_encoding
# spent 15µs making 1 call to Encode::Encoding::renew
# spent 3µs making 1 call to Encode::Encoding::needs_lines |
129 | 1 | 12µs | 4 | 82µs | binmode(STDERR, ":$1"); # spent 50µs making 1 call to open::CORE:binmode
# spent 15µs making 1 call to Encode::Encoding::renew
# spent 14µs making 1 call to Encode::find_encoding
# spent 3µs making 1 call to Encode::Encoding::needs_lines |
130 | } | ||||
131 | } | ||||
132 | } | ||||
133 | } | ||||
134 | |||||
135 | 1 | 10µs | 1; | ||
136 | __END__ | ||||
sub open::CORE:binmode; # opcode | |||||
# spent 37µs within open::CORE:match which was called 9 times, avg 4µs/call:
# 2 times (15µs+0s) by open::import at line 63, avg 8µs/call
# 2 times (6µs+0s) by open::_drop_oldenc at line 36, avg 3µs/call
# 2 times (6µs+0s) by open::import at line 117, avg 3µs/call
# 2 times (4µs+0s) by open::import at line 124, avg 2µs/call
# once (6µs+0s) by open::import at line 93 | |||||
sub open::CORE:subst; # opcode | |||||
# spent 8µs within open::CORE:substcont which was called 2 times, avg 4µs/call:
# 2 times (8µs+0s) by open::import at line 86, avg 4µs/call |