| Filename | /usr/share/perl/5.36/open.pm |
| Statements | Executed 78 statements in 618µs |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 3 | 3 | 3 | 62µs | 78µs | open::import |
| 6 | 2 | 1 | 8µs | 8µs | open::CORE:match (opcode) |
| 1 | 1 | 1 | 6µs | 17µs | open::BEGIN@2 |
| 6 | 2 | 1 | 4µs | 4µs | open::CORE:subst (opcode) |
| 0 | 0 | 0 | 0s | 0s | open::_drop_oldenc |
| 0 | 0 | 0 | 0s | 0s | open::_get_encname |
| 0 | 0 | 0 | 0s | 0s | open::croak |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package open; | ||||
| 2 | 2 | 530µs | 2 | 27µs | # spent 17µs (6+11) within open::BEGIN@2 which was called:
# once (6µs+11µs) by main::BEGIN@6 at line 2 # spent 17µs making 1 call to open::BEGIN@2
# spent 10µs making 1 call to warnings::import |
| 3 | |||||
| 4 | 1 | 200ns | our $VERSION = '1.13'; | ||
| 5 | |||||
| 6 | 1 | 6µs | require 5.008001; # for PerlIO::get_layers() | ||
| 7 | |||||
| 8 | 1 | 100ns | 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 | my ($h, @new) = @_; | ||||
| 36 | return unless @new >= 1 && $new[-1] =~ /^:encoding\(.+\)$/; | ||||
| 37 | my @old = PerlIO::get_layers($h); | ||||
| 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 78µs (62+16) within open::import which was called 3 times, avg 26µs/call:
# once (24µs+7µs) by main::BEGIN@6 at line 6 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/bin/split.pl
# once (22µs+5µs) by Gradescope::Translate::BEGIN@5 at line 5 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/lib/Gradescope/Translate.pm
# once (16µs+4µs) by Gradescope::Color::BEGIN@5 at line 5 of /home/hejohns/documentsNoSync/22f/490/gradescope-utils/lib/Gradescope/Color.pm | ||||
| 56 | 3 | 2µs | my ($class,@args) = @_; | ||
| 57 | 3 | 600ns | croak("open: needs explicit list of PerlIO layers") unless @args; | ||
| 58 | 3 | 300ns | my $std; | ||
| 59 | 3 | 4µs | my ($in,$out) = split(/\0/,(${^OPEN} || "\0"), -1); | ||
| 60 | 3 | 800ns | while (@args) { | ||
| 61 | 3 | 1µs | my $type = shift(@args); | ||
| 62 | 3 | 300ns | my $dscp; | ||
| 63 | 3 | 13µs | 3 | 6µs | if ($type =~ /^:?(utf8|locale|encoding\(.+\))$/) { # spent 6µs making 3 calls to open::CORE:match, avg 2µs/call |
| 64 | 3 | 700ns | $type = 'IO'; | ||
| 65 | 3 | 3µs | $dscp = ":$1"; | ||
| 66 | } elsif ($type eq ':std') { | ||||
| 67 | $std = 1; | ||||
| 68 | next; | ||||
| 69 | } else { | ||||
| 70 | $dscp = shift(@args) || ''; | ||||
| 71 | } | ||||
| 72 | 3 | 600ns | my @val; | ||
| 73 | 3 | 2µs | foreach my $layer (split(/\s+/,$dscp)) { | ||
| 74 | 3 | 6µs | 3 | 3µs | $layer =~ s/^://; # spent 3µs making 3 calls to open::CORE:subst, avg 1µs/call |
| 75 | 3 | 4µs | 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 | 3 | 700ns | my $target = $layer; # the layer name itself | ||
| 86 | 3 | 3µs | 3 | 700ns | $target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters # spent 700ns making 3 calls to open::CORE:subst, avg 233ns/call |
| 87 | |||||
| 88 | 3 | 14µs | 3 | 4µs | unless(PerlIO::Layer::->find($target,1)) { # spent 4µs making 3 calls to PerlIO::Layer::find, avg 1µs/call |
| 89 | warnings::warnif("layer", "Unknown PerlIO layer '$target'"); | ||||
| 90 | } | ||||
| 91 | } | ||||
| 92 | 3 | 2µs | push(@val,":$layer"); | ||
| 93 | 3 | 5µs | 3 | 2µs | if ($layer =~ /^(crlf|raw)$/) { # spent 2µs making 3 calls to open::CORE:match, avg 600ns/call |
| 94 | $^H{"open_$type"} = $layer; | ||||
| 95 | } | ||||
| 96 | } | ||||
| 97 | 3 | 3µs | if ($type eq 'IN') { | ||
| 98 | _drop_oldenc(*STDIN, @val) if $std; | ||||
| 99 | $in = join(' ', @val); | ||||
| 100 | } | ||||
| 101 | elsif ($type eq 'OUT') { | ||||
| 102 | if ($std) { | ||||
| 103 | _drop_oldenc(*STDOUT, @val); | ||||
| 104 | _drop_oldenc(*STDERR, @val); | ||||
| 105 | } | ||||
| 106 | $out = join(' ', @val); | ||||
| 107 | } | ||||
| 108 | elsif ($type eq 'IO') { | ||||
| 109 | 3 | 400ns | if ($std) { | ||
| 110 | _drop_oldenc(*STDIN, @val); | ||||
| 111 | _drop_oldenc(*STDOUT, @val); | ||||
| 112 | _drop_oldenc(*STDERR, @val); | ||||
| 113 | } | ||||
| 114 | 3 | 2µs | $in = $out = join(' ', @val); | ||
| 115 | } | ||||
| 116 | else { | ||||
| 117 | croak "Unknown PerlIO layer class '$type' (need IN, OUT or IO)"; | ||||
| 118 | } | ||||
| 119 | } | ||||
| 120 | 3 | 7µs | ${^OPEN} = join("\0", $in, $out); | ||
| 121 | 3 | 4µs | if ($std) { | ||
| 122 | if ($in) { | ||||
| 123 | binmode STDIN, $in; | ||||
| 124 | } | ||||
| 125 | if ($out) { | ||||
| 126 | binmode(STDOUT, $out); | ||||
| 127 | binmode(STDERR, $out); | ||||
| 128 | } | ||||
| 129 | } | ||||
| 130 | } | ||||
| 131 | |||||
| 132 | 1 | 2µs | 1; | ||
| 133 | __END__ | ||||
sub open::CORE:match; # opcode | |||||
sub open::CORE:subst; # opcode |