Filename | /home/hinrik/perl5/perlbrew/perls/perl-5.13.5/lib/site_perl/5.13.5/IO/Interactive.pm |
Statements | Executed 34 statements in 1.16ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 2.10ms | 4.15ms | BEGIN@76 | IO::Interactive::
1 | 1 | 1 | 790µs | 1.25ms | BEGIN@3 | IO::Interactive::
3 | 1 | 1 | 70µs | 184µs | is_interactive | IO::Interactive::
1 | 1 | 1 | 30µs | 30µs | BEGIN@37 | IO::Interactive::
6 | 2 | 1 | 28µs | 28µs | CORE:fttty (opcode) | IO::Interactive::
1 | 1 | 1 | 15µs | 92µs | BEGIN@7 | IO::Interactive::
1 | 1 | 1 | 15µs | 83µs | BEGIN@8 | IO::Interactive::
1 | 1 | 1 | 14µs | 35µs | BEGIN@5 | IO::Interactive::
1 | 1 | 1 | 13µs | 70µs | BEGIN@115 | IO::Interactive::
1 | 1 | 1 | 11µs | 16µs | BEGIN@6 | IO::Interactive::
1 | 1 | 1 | 11µs | 31µs | BEGIN@123 | IO::Interactive::
3 | 1 | 1 | 8µs | 8µs | CORE:select (opcode) | IO::Interactive::
0 | 0 | 0 | 0s | 0s | _input_pending_on | IO::Interactive::
0 | 0 | 0 | 0s | 0s | busy | IO::Interactive::
0 | 0 | 0 | 0s | 0s | import | IO::Interactive::
0 | 0 | 0 | 0s | 0s | interactive | IO::Interactive::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package IO::Interactive; | ||||
2 | |||||
3 | 3 | 181µs | 3 | 1.29ms | # spent 1.25ms (790µs+460µs) within IO::Interactive::BEGIN@3 which was called:
# once (790µs+460µs) by Hailo::_is_interactive at line 3 # spent 1.25ms making 1 call to IO::Interactive::BEGIN@3
# spent 23µs making 1 call to version::import
# spent 17µs making 1 call to version::__ANON__[version.pm:151] |
4 | |||||
5 | 2 | 27µs | 2 | 56µs | # spent 35µs (14+21) within IO::Interactive::BEGIN@5 which was called:
# once (14µs+21µs) by Hailo::_is_interactive at line 5 # spent 35µs making 1 call to IO::Interactive::BEGIN@5
# spent 21µs making 1 call to warnings::import |
6 | 2 | 25µs | 2 | 21µs | # spent 16µs (11+5) within IO::Interactive::BEGIN@6 which was called:
# once (11µs+5µs) by Hailo::_is_interactive at line 6 # spent 16µs making 1 call to IO::Interactive::BEGIN@6
# spent 5µs making 1 call to strict::import |
7 | 2 | 39µs | 2 | 169µs | # spent 92µs (15+77) within IO::Interactive::BEGIN@7 which was called:
# once (15µs+77µs) by Hailo::_is_interactive at line 7 # spent 92µs making 1 call to IO::Interactive::BEGIN@7
# spent 77µs making 1 call to Exporter::import |
8 | 2 | 126µs | 2 | 151µs | # spent 83µs (15+68) within IO::Interactive::BEGIN@8 which was called:
# once (15µs+68µs) by Hailo::_is_interactive at line 8 # spent 83µs making 1 call to IO::Interactive::BEGIN@8
# spent 68µs making 1 call to Exporter::import |
9 | |||||
10 | # spent 184µs (70+113) within IO::Interactive::is_interactive which was called 3 times, avg 61µs/call:
# 3 times (70µs+113µs) by Hailo::_is_interactive at line 340 of lib/Hailo.pm, avg 61µs/call | ||||
11 | 3 | 25µs | 3 | 8µs | my ($out_handle) = (@_, select); # Default to default output handle # spent 8µs making 3 calls to IO::Interactive::CORE:select, avg 3µs/call |
12 | |||||
13 | # Not interactive if output is not to terminal... | ||||
14 | 3 | 36µs | 3 | 21µs | return 0 if not -t $out_handle; # spent 21µs making 3 calls to IO::Interactive::CORE:fttty, avg 7µs/call |
15 | |||||
16 | # If *ARGV is opened, we're interactive if... | ||||
17 | 3 | 16µs | 3 | 77µs | if (openhandle *ARGV) { # spent 77µs making 3 calls to Scalar::Util::openhandle, avg 26µs/call |
18 | # ...it's currently opened to the magic '-' file | ||||
19 | return -t *STDIN if defined $ARGV && $ARGV eq '-'; | ||||
20 | |||||
21 | # ...it's at end-of-file and the next file is the magic '-' file | ||||
22 | return @ARGV>0 && $ARGV[0] eq '-' && -t *STDIN if eof *ARGV; | ||||
23 | |||||
24 | # ...it's directly attached to the terminal | ||||
25 | return -t *ARGV; | ||||
26 | } | ||||
27 | |||||
28 | # If *ARGV isn't opened, it will be interactive if *STDIN is attached | ||||
29 | # to a terminal. | ||||
30 | else { | ||||
31 | 3 | 30µs | 3 | 7µs | return -t *STDIN; # spent 7µs making 3 calls to IO::Interactive::CORE:fttty, avg 2µs/call |
32 | } | ||||
33 | } | ||||
34 | |||||
35 | 1 | 3µs | local (*DEV_NULL, *DEV_NULL2); | ||
36 | 1 | 1µs | my $dev_null; | ||
37 | # spent 30µs within IO::Interactive::BEGIN@37 which was called:
# once (30µs+0s) by Hailo::_is_interactive at line 41 | ||||
38 | 1 | 24µs | pipe *DEV_NULL, *DEV_NULL2 | ||
39 | or die "Internal error: can't create null filehandle"; | ||||
40 | 1 | 7µs | $dev_null = \*DEV_NULL; | ||
41 | 1 | 145µs | 1 | 30µs | } # spent 30µs making 1 call to IO::Interactive::BEGIN@37 |
42 | |||||
43 | sub interactive { | ||||
44 | my ($out_handle) = (@_, \*STDOUT); # Default to STDOUT | ||||
45 | return &is_interactive ? $out_handle : $dev_null; | ||||
46 | } | ||||
47 | |||||
48 | sub _input_pending_on { | ||||
49 | my ($fh) = @_; | ||||
50 | my $read_bits = ""; | ||||
51 | my $bit = fileno($fh); | ||||
52 | return if $bit < 0; | ||||
53 | vec($read_bits, fileno($fh), 1) = 1; | ||||
54 | select $read_bits, undef, undef, 0.1; | ||||
55 | return $read_bits; | ||||
56 | } | ||||
57 | |||||
58 | sub busy (&) { | ||||
59 | my ($block_ref) = @_; | ||||
60 | |||||
61 | # Non-interactive busy-ness is easy...just do it | ||||
62 | if (!is_interactive()) { | ||||
63 | $block_ref->(); | ||||
64 | open my $fh, '<', \""; | ||||
65 | return $fh; | ||||
66 | } | ||||
67 | |||||
68 | # Otherwise fork off an interceptor process... | ||||
69 | my ($read, $write); | ||||
70 | pipe $read, $write; | ||||
71 | my $child = fork; | ||||
72 | |||||
73 | # Within that interceptor process... | ||||
74 | if (!$child) { | ||||
75 | # Prepare to send back any intercepted input... | ||||
76 | 2 | 342µs | 2 | 4.18ms | # spent 4.15ms (2.10+2.04) within IO::Interactive::BEGIN@76 which was called:
# once (2.10ms+2.04ms) by Hailo::_is_interactive at line 76 # spent 4.15ms making 1 call to IO::Interactive::BEGIN@76
# spent 36µs making 1 call to Exporter::import |
77 | close $read; | ||||
78 | $write->autoflush(1); | ||||
79 | |||||
80 | # Intercept that input... | ||||
81 | while (1) { | ||||
82 | if (_input_pending_on(\*ARGV)) { | ||||
83 | # Read it... | ||||
84 | my $res = <ARGV>; | ||||
85 | |||||
86 | # Send it back to the parent... | ||||
87 | print {$write} $res; | ||||
88 | |||||
89 | # Admonish them for not waiting... | ||||
90 | print {*STDERR} "That input was ignored. ", | ||||
91 | "Please don't press any keys yet.\n"; | ||||
92 | } | ||||
93 | } | ||||
94 | exit; | ||||
95 | } | ||||
96 | |||||
97 | # Meanwhile, back in the parent... | ||||
98 | close $write; | ||||
99 | |||||
100 | # Temporarily close the input... | ||||
101 | local *ARGV; | ||||
102 | open *ARGV, '<', \""; | ||||
103 | |||||
104 | # Do the job... | ||||
105 | $block_ref->(); | ||||
106 | |||||
107 | # Take down the interceptor... | ||||
108 | kill 9, $child; | ||||
109 | wait; | ||||
110 | |||||
111 | # Return whatever the interceptor caught... | ||||
112 | return $read; | ||||
113 | } | ||||
114 | |||||
115 | 2 | 47µs | 2 | 128µs | # spent 70µs (13+57) within IO::Interactive::BEGIN@115 which was called:
# once (13µs+57µs) by Hailo::_is_interactive at line 115 # spent 70µs making 1 call to IO::Interactive::BEGIN@115
# spent 57µs making 1 call to Exporter::import |
116 | |||||
117 | sub import { | ||||
118 | my ($package) = shift; | ||||
119 | my $caller = caller; | ||||
120 | |||||
121 | # Export each sub if it's requested... | ||||
122 | for my $request ( @_ ) { | ||||
123 | 2 | 78µs | 2 | 52µs | # spent 31µs (11+21) within IO::Interactive::BEGIN@123 which was called:
# once (11µs+21µs) by Hailo::_is_interactive at line 123 # spent 31µs making 1 call to IO::Interactive::BEGIN@123
# spent 21µs making 1 call to strict::unimport |
124 | my $impl = *{$package.'::'.$request}{CODE}; | ||||
125 | croak "Unknown subroutine ($request()) requested" | ||||
126 | if !$impl || $request =~ m/\A _/xms; | ||||
127 | *{$caller.'::'.$request} = $impl; | ||||
128 | } | ||||
129 | } | ||||
130 | |||||
131 | |||||
132 | 1 | 5µs | 1; # Magic true value required at end of module | ||
133 | __END__ | ||||
sub IO::Interactive::CORE:fttty; # opcode | |||||
# spent 8µs within IO::Interactive::CORE:select which was called 3 times, avg 3µs/call:
# 3 times (8µs+0s) by IO::Interactive::is_interactive at line 11, avg 3µs/call |