| 1 | package CommandTerm::ProgPty; |
| 2 | |
| 3 | require 5.004; |
| 4 | use strict; |
| 5 | use Getopt::Long; |
| 6 | use IO::Pty; |
| 7 | use POSIX; |
| 8 | |
| 9 | use vars qw( |
| 10 | @ISA |
| 11 | $VERSION |
| 12 | $Verbose |
| 13 | $PrintFunc |
| 14 | $AUTOLOAD |
| 15 | ); |
| 16 | |
| 17 | $VERSION = '1.00'; |
| 18 | $Verbose = 3; |
| 19 | $PrintFunc = undef; |
| 20 | |
| 21 | sub new { |
| 22 | my ($class, $progname, @opts) = @_; |
| 23 | my $this = {}; |
| 24 | |
| 25 | bless $this, $class; |
| 26 | |
| 27 | $this->{'read_buf'} = ''; |
| 28 | $this->{'alive'} = 1; |
| 29 | $this->{'prompt'} = 'rivet> '; |
| 30 | $this->{'response_pending'} = 0; |
| 31 | |
| 32 | if( defined($PrintFunc) ) { |
| 33 | $this->{'printfunc'} = $PrintFunc; |
| 34 | } else { |
| 35 | $| = 1; |
| 36 | $this->{'printfunc'} = sub { $this->default_print(@_); }; |
| 37 | } |
| 38 | |
| 39 | $this->verbose($Verbose); |
| 40 | $this->print_status(8, "SETTING VERBOSE LEVEL TO $Verbose\n"); |
| 41 | |
| 42 | my $resolved_progname = which($progname); |
| 43 | |
| 44 | unless( $resolved_progname ) { |
| 45 | $this->print_error(0, "Can't find '$progname', check your path.\n"); |
| 46 | return undef; |
| 47 | } |
| 48 | |
| 49 | my @prog_exec_opts = ($resolved_progname, @opts); |
| 50 | |
| 51 | $this->install_error_handler(\&default_error_handler); |
| 52 | $this->reset_data_handler; |
| 53 | |
| 54 | $this->{'pty'} = new IO::Pty; |
| 55 | $this->pty->autoflush(1); |
| 56 | |
| 57 | if( $this->pty->IO::Pty::ttyname ) { |
| 58 | $this->print_status(8, "OPENED A PTY NAMED '", $this->pty->IO::Pty::ttyname, "'\n"); |
| 59 | } else { |
| 60 | $this->print_error(0, "Couldn't get a ttyname for IO::Pty. Proceeding anyway\n"); |
| 61 | } |
| 62 | |
| 63 | # Parent |
| 64 | if( $this->{'pid'} = fork ) { |
| 65 | $this->{'fileno'} = $this->pty->fileno; |
| 66 | $this->print_status(8, "FORKED '$prog_exec_opts[0]'\n", |
| 67 | " PID ", $this->pid, "\n", |
| 68 | " FILENO ", $this->fileno, "\n"); |
| 69 | |
| 70 | # read data until a prompt |
| 71 | my $response = $this->wait_response; |
| 72 | |
| 73 | return undef unless defined($response); |
| 74 | |
| 75 | # Normal return point |
| 76 | return $this; |
| 77 | |
| 78 | # Child |
| 79 | } elsif( defined($this->pid) ) { |
| 80 | POSIX::setsid or die; |
| 81 | my $tty = $this->pty->slave; |
| 82 | |
| 83 | # Below are 6 lines of terminal wizardry turn out to really save the |
| 84 | # day for this whole module. If you set the terminal correctly, many |
| 85 | # problems simply disappear and things start working great. So what do |
| 86 | # these lines do? Here we go: |
| 87 | # |
| 88 | # 1) The part that says ~(ECHO | ECHOE | ECHOK | ECHONL) turns off all local |
| 89 | # echoing. Imagine your sitting at a keyboard and you type the command |
| 90 | # "cat -". The cat command reads your keystrokes and echoes them when |
| 91 | # you press return. But notice how you can see what you're typing as |
| 92 | # hit the keys. After you hit return, the cat echoes again everything |
| 93 | # you just entered and you see what you typed twice. The moral of the |
| 94 | # story is that cat relies on the terminal being in "ECHO" mode to allow |
| 95 | # the user to see what they're typing as they type it. Now imagine |
| 96 | # you're a process writing to the terminal of another process *AND* your |
| 97 | # stdin and stdout are tied to the same file handle. If the terminal |
| 98 | # were in echo mode, the first thing you'd ever read from the terminal |
| 99 | # is the exact thing that you sent to it. By turning off ECHO, we save |
| 100 | # ourselves the trouble of removing what we sent from the return data |
| 101 | # stream. If you ever looked at the original dc_perl by Steve Golson, |
| 102 | # you saw how he went to great effort to remove the first line he got |
| 103 | # back. |
| 104 | # |
| 105 | # 2) The part that says ~(ICANON) turns off canonical mode processing. |
| 106 | # When canonical mode is enabled, the terminal assembles the input |
| 107 | # characters into lines and also has a fixed line length. This presents |
| 108 | # two problems for Synopsys. The most obvious one is that our line |
| 109 | # length is limited by the length of the canonical mode input queue. For |
| 110 | # my box (Sun Solaris 2.6) that is 256 characters. The second |
| 111 | # reason is a little more esoteric. One of the features of Synopsys |
| 112 | # is that it only ties STDOUT back to itself. STDERR is left alone to |
| 113 | # allow users to print to it from their Tcl scripts, bypassing |
| 114 | # Synopsys. With this setup, if native Synopsys paging were enabled |
| 115 | # and activated (a paging command were issued), the terminal would hang. |
| 116 | # I don't really have a good explanation of why, but obviously something |
| 117 | # in the canonical processing is causing the terminal to hang. Even more |
| 118 | # mysterious is the fact that when STDERR is also tied back to |
| 119 | # $tty->fileno, the problem goes away, but the user loses the ability to |
| 120 | # bypass Synopsys by printing to STDERR. This is not a good trade. |
| 121 | # |
| 122 | # Well, almost no worries. When you disable canonical mode processing, |
| 123 | # the terminal won't deliver data to the reader unless a certain number |
| 124 | # of bytes have been received, EVEN if one of those bytes is a newline |
| 125 | # (since a newline loses it's meaning in non-canonical mode). Actually, |
| 126 | # I'm lying again because non-canonical mode really has 4 modes of |
| 127 | # operation and I'm just speaking about two of them. Anyway, on my box |
| 128 | # (Solaris 2.6) the default minimum number of bytes to receive before |
| 129 | # delivery is 4 (even that's a long story). That's no good. I want |
| 130 | # Synosys to read byte if I send a byte. Of course, I can setup the |
| 131 | # terminal anyway that I want. So I set the magical VMIN to 1 and the |
| 132 | # VTIME to 0 which tells the terminal to deliver a mininum of 1 bytes to |
| 133 | # Synopsys every time it tries to read. If nothing is available to read, |
| 134 | # the Synopsys will block. I'm assuming that Synopsys was written to |
| 135 | # block on a read when nothing is available so that's ok. |
| 136 | # |
| 137 | # So life is good. I don't have to re-extract the data I sent. I don't have |
| 138 | # line length limit. I can leave STDERR alone and still not care whether |
| 139 | # the user enables native paging. Actually, It's still recommended that |
| 140 | # native paging be disabled because I still see the occasional hiccup that |
| 141 | # I can't explain. |
| 142 | my $termios = POSIX::Termios->new; |
| 143 | $termios->getattr($tty->fileno) or die; |
| 144 | $termios->setlflag($termios->getlflag & ~(ECHO | ECHOE | ECHOK | ECHONL | ICANON)); |
| 145 | $termios->setcc(VMIN, 1); |
| 146 | $termios->setcc(VTIME, 0); |
| 147 | $termios->setattr($tty->fileno, TCSANOW) or die; |
| 148 | |
| 149 | close $this->pty; |
| 150 | close STDIN; |
| 151 | close STDOUT; |
| 152 | open(STDIN, "<&" . $tty->fileno) or die "Child Error: Couldn't re-open STDIN: $!"; |
| 153 | open(STDOUT, ">&" . $tty->fileno) or die "Child Error: Couldn't re-open STDOUT: $!"; |
| 154 | |
| 155 | exec(@prog_exec_opts); |
| 156 | |
| 157 | # Error |
| 158 | } else { |
| 159 | $this->print_error(0, "FORK FAILED: $!\n"); |
| 160 | return undef; |
| 161 | } |
| 162 | } |
| 163 | |
| 164 | sub DESTROY {} |
| 165 | |
| 166 | sub AUTOLOAD { |
| 167 | my ($this, @opts) = @_; |
| 168 | my $method = $AUTOLOAD; |
| 169 | |
| 170 | $method =~ s/.*:://; |
| 171 | |
| 172 | return $this->print_error(1, "$method @opts\n"); |
| 173 | } |
| 174 | |
| 175 | sub default_error_handler { |
| 176 | my ($this, $error_type) = @_; |
| 177 | |
| 178 | if( $error_type == 1 ) { |
| 179 | if( $this->verbose < 3 ) { |
| 180 | $this->print_error(1, "Error with the command '", |
| 181 | $this->current_command, "'\n\n", |
| 182 | $this->output_string); |
| 183 | } |
| 184 | } elsif( $error_type == -1 ) { |
| 185 | $this->print_error(0, "Fatal error, exiting.\n"); |
| 186 | exit; |
| 187 | } |
| 188 | } |
| 189 | |
| 190 | sub perl_list2tcl_list { |
| 191 | my $this = shift; |
| 192 | |
| 193 | return (not defined($_[0]) or @_ < 1) ? '""' : return "[list @_]"; |
| 194 | } |
| 195 | |
| 196 | sub get_options { |
| 197 | my ($this, $argv_ref, $config_ref, @opts) = (@_); |
| 198 | |
| 199 | local (@ARGV) = @$argv_ref; |
| 200 | Getopt::Long::config(@$config_ref) if @$config_ref > 0; |
| 201 | my $ret = GetOptions(@opts); |
| 202 | Getopt::Long::config('default'); |
| 203 | @$argv_ref = @ARGV; |
| 204 | return $ret; |
| 205 | } |
| 206 | |
| 207 | sub alive { |
| 208 | my $this = shift; |
| 209 | |
| 210 | return $this->{'alive'}; |
| 211 | } |
| 212 | |
| 213 | sub verbose { |
| 214 | my ($this, $verbose) = @_; |
| 215 | |
| 216 | my $old_verbose = $this->{'verbose'}; |
| 217 | |
| 218 | $this->{'verbose'} = $verbose if defined($verbose); |
| 219 | |
| 220 | return $old_verbose; |
| 221 | } |
| 222 | |
| 223 | sub print_data { |
| 224 | my ($this, $verbose, @what) = @_; |
| 225 | |
| 226 | &{ $this->{'printfunc'} }('data', @what) if $this->verbose >= $verbose; |
| 227 | } |
| 228 | |
| 229 | sub print_status { |
| 230 | my ($this, $verbose, @what) = @_; |
| 231 | |
| 232 | &{ $this->{'printfunc'} }('status', @what) if $this->verbose >= $verbose; |
| 233 | } |
| 234 | |
| 235 | sub print_error { |
| 236 | my ($this, $verbose, @what) = @_; |
| 237 | |
| 238 | &{ $this->{'printfunc'} }('error', @what) if $this->verbose >= $verbose; |
| 239 | } |
| 240 | |
| 241 | sub default_print { |
| 242 | my ($this, $type, @what) = @_; |
| 243 | |
| 244 | print STDOUT @what; |
| 245 | } |
| 246 | |
| 247 | sub reset_data_handler { |
| 248 | my ($this) = @_; |
| 249 | |
| 250 | $this->{'data_handler'} = undef; |
| 251 | } |
| 252 | |
| 253 | sub install_print_handler { |
| 254 | my ($this, $handler) = @_; |
| 255 | |
| 256 | unless( defined($handler) and ref($handler) eq 'CODE' ) { |
| 257 | $this->print_error(1, "Argument to install_print_handler must be a CODE ref.\n"); |
| 258 | return; |
| 259 | } |
| 260 | |
| 261 | $this->{'printfunc'} = $handler; |
| 262 | } |
| 263 | |
| 264 | sub install_data_handler { |
| 265 | my ($this, $handler) = @_; |
| 266 | |
| 267 | unless( defined($handler) and ref($handler) eq 'CODE' ) { |
| 268 | $this->print_error(1, "Argument to install_data_handler must be a CODE ref.\n"); |
| 269 | return; |
| 270 | } |
| 271 | |
| 272 | $this->{'data_handler'} = $handler; |
| 273 | } |
| 274 | |
| 275 | sub install_error_handler { |
| 276 | my ($this, $handler) = @_; |
| 277 | |
| 278 | unless( defined($handler) and ref($handler) eq 'CODE' ) { |
| 279 | $this->print_error(1, "Argument to install_error_handler must be a CODE ref.\n"); |
| 280 | return; |
| 281 | } |
| 282 | |
| 283 | $this->{'error_handler'} = $handler; |
| 284 | } |
| 285 | |
| 286 | sub current_command { |
| 287 | my $this = shift; |
| 288 | |
| 289 | return $this->{'current_command'}; |
| 290 | } |
| 291 | |
| 292 | sub output_lines { |
| 293 | my $this = shift; |
| 294 | |
| 295 | return @{ $this->{'output_lines'} }; |
| 296 | } |
| 297 | |
| 298 | sub output_lastline { |
| 299 | my $this = shift; |
| 300 | |
| 301 | return $this->{'output_lastline'}; |
| 302 | } |
| 303 | |
| 304 | sub output_string { |
| 305 | my $this = shift; |
| 306 | |
| 307 | return $this->{'output_string'}; |
| 308 | } |
| 309 | |
| 310 | sub run { |
| 311 | my ($this, $command, $verbose, $update) = @_; |
| 312 | |
| 313 | unless( defined($command) ) { |
| 314 | $this->print_error(1, "Argument to run ommitted.\n"); |
| 315 | return undef; |
| 316 | } |
| 317 | |
| 318 | $this->{'current_command'} = $command |
| 319 | unless( defined($update) and $update == 0 ); |
| 320 | |
| 321 | my $old_verbose = $this->verbose; |
| 322 | |
| 323 | $this->verbose($verbose) |
| 324 | if defined($verbose) and ($this->verbose < 4 or $verbose == 0); |
| 325 | |
| 326 | $this->write_data("$command\n"); |
| 327 | |
| 328 | my $retval = $this->wait_response($update); |
| 329 | |
| 330 | # It doesn't hurt to restore, even if we didn't change it. |
| 331 | $this->verbose($old_verbose); |
| 332 | |
| 333 | return $retval; |
| 334 | } |
| 335 | |
| 336 | sub _output_lines { |
| 337 | my $this = shift; |
| 338 | |
| 339 | return split /\n/, $this->{'current_response'}; |
| 340 | } |
| 341 | |
| 342 | sub _output_lastline { |
| 343 | my $this = shift; |
| 344 | |
| 345 | my @output_lines = split /\n/, $this->{'current_response'}; |
| 346 | return $output_lines[ $#output_lines ]; |
| 347 | } |
| 348 | |
| 349 | sub fileno { |
| 350 | my $this = shift; |
| 351 | |
| 352 | return $this->{'fileno'}; |
| 353 | } |
| 354 | |
| 355 | sub pid { |
| 356 | my $this = shift; |
| 357 | |
| 358 | return $this->{'pid'}; |
| 359 | } |
| 360 | |
| 361 | sub pty { |
| 362 | my $this = shift; |
| 363 | |
| 364 | return $this->{'pty'}; |
| 365 | } |
| 366 | |
| 367 | sub write_data { |
| 368 | my ($this, $data) = @_; |
| 369 | |
| 370 | return unless defined($data) and length($data) > 0; |
| 371 | |
| 372 | $this->print_status(4, "$data"); |
| 373 | $this->print_status(8, "WRITING ", length($data), " BYTES TO PTY\n"); |
| 374 | $this->print_status(10, "WRITE DATA: '", _make_readable($data), "'\n"); |
| 375 | |
| 376 | print { $this->pty } $data; |
| 377 | } |
| 378 | |
| 379 | sub readable { |
| 380 | my $this = shift; |
| 381 | my $fd_set; |
| 382 | |
| 383 | vec($fd_set, $this->fileno, 1) = 1; |
| 384 | |
| 385 | return select($fd_set, undef, undef, 0); |
| 386 | } |
| 387 | |
| 388 | sub wait_response { |
| 389 | my ($this, $update) = @_; |
| 390 | |
| 391 | if( $this->{'response_pending'} == 0 ) { |
| 392 | |
| 393 | $this->{'current_response'} = ''; |
| 394 | $this->{'partial_response'} = ''; |
| 395 | |
| 396 | my ($fd_set, $global_fd) = ('', ''); |
| 397 | |
| 398 | vec($global_fd, $this->fileno, 1) = 1; |
| 399 | |
| 400 | my $done = 0; |
| 401 | |
| 402 | while( not $done ) { |
| 403 | |
| 404 | $this->print_status(8, "BLOCKING ON SELECT\n"); |
| 405 | |
| 406 | my $s = select($fd_set = $global_fd, undef, undef, undef); |
| 407 | |
| 408 | $this->print_status(8, "SELECT RETURNS ", defined($s) ? $s : "UNDEFINED", "\n"); |
| 409 | |
| 410 | if( $s < 0 ) { |
| 411 | $this->print_error(8, "SELECT ERROR: $!\n"); |
| 412 | &{ $this->{'error_handler'} }($this, 0); |
| 413 | return 0; |
| 414 | } |
| 415 | |
| 416 | if( vec($fd_set, $this->fileno, 1) ) { |
| 417 | $done = $this->read_data; |
| 418 | return undef unless defined($done); |
| 419 | } |
| 420 | } |
| 421 | } |
| 422 | |
| 423 | $this->print_status(10, "RESPONSE: '", _make_readable($this->{'current_response'}), "'\n"); |
| 424 | |
| 425 | $update = 1 unless defined($update); |
| 426 | |
| 427 | if( $update ) { |
| 428 | $this->{'output_string'} = $this->{'current_response'}; |
| 429 | $this->{'output_lines'} = [ split /\n/, $this->{'current_response'} ]; |
| 430 | $this->{'output_lastline'} = |
| 431 | ${ $this->{'output_lines'} }[ $#{ $this->{'output_lines'} } ]; |
| 432 | } |
| 433 | |
| 434 | $this->{'response_pending'} = 0; |
| 435 | |
| 436 | my $retval = ($this->{'current_response'} =~ /^Error: /m) ? 0 : 1; |
| 437 | |
| 438 | &{ $this->{'error_handler'} }($this, 1) if $retval == 0; |
| 439 | |
| 440 | return $retval; |
| 441 | } |
| 442 | |
| 443 | sub read_data { |
| 444 | my $this = shift; |
| 445 | |
| 446 | $this->print_status(8, "BLOCKING ON SYSREAD\n"); |
| 447 | |
| 448 | my $nbytes = |
| 449 | sysread($this->pty, $this->{'read_buf'}, 2048, length($this->{'read_buf'})); |
| 450 | |
| 451 | $this->print_status(8, "SYSREAD RETURNS: ", defined($nbytes) ? $nbytes : "UNDEFINED", "\n"); |
| 452 | |
| 453 | # Error from sysread |
| 454 | if( not defined($nbytes) ) { |
| 455 | # check to see if prog is still alive |
| 456 | my $pid = waitpid($this->pid, WNOHANG); |
| 457 | |
| 458 | # Normal termination. |
| 459 | if( $pid = $this->pid ) { |
| 460 | $this->{'alive'} = 0; |
| 461 | $this->print_status(8, "WAITPID RETURNS. PID: $pid, NORMAL EXIT STATUS.\n"); |
| 462 | return undef; |
| 463 | |
| 464 | # Still alive! |
| 465 | } elsif( $pid == 0 ) { |
| 466 | return 0; |
| 467 | |
| 468 | # Yikes! Unexpected error. |
| 469 | } else { |
| 470 | $this->print_error(0, "waitpid on pid($this->{'pid'}) returned $pid: $!.\n"); |
| 471 | $this->{'alive'} = 0; |
| 472 | &{ $this->{'error_handler'} }($this, -1); |
| 473 | return undef; |
| 474 | } |
| 475 | |
| 476 | # EOF from sysread |
| 477 | } elsif( $nbytes == 0 ) { |
| 478 | $this->print_status(8, "GOT EOF FROM SYSREAD.\n"); |
| 479 | $this->{'alive'} = 0; |
| 480 | return undef; |
| 481 | |
| 482 | # Data from sysread |
| 483 | } else { |
| 484 | $this->print_status(10, "RAW DATA: '", _make_readable($this->{'read_buf'}), "'\n"); |
| 485 | |
| 486 | if( defined($this->{'data_handler'}) ) { |
| 487 | $this->{'partial_response'} .= $this->{'read_buf'}; |
| 488 | $this->{'partial_response'} =~ s/(\r|\e.{0,2})//mg; |
| 489 | my @partial_lines = split /\n/, $this->{'partial_response'}; |
| 490 | if( $this->{'partial_response'} =~ /\n$/ ) { |
| 491 | $this->{'partial_response'} = ''; |
| 492 | } else { |
| 493 | $this->{'partial_response'} = pop @partial_lines; |
| 494 | } |
| 495 | &{ $this->{'data_handler'} }($this, @partial_lines); |
| 496 | } |
| 497 | |
| 498 | my $before; |
| 499 | |
| 500 | # The data read contains a prompt. Process all the prompts. Multiple prompts |
| 501 | # will be in the data when the user hits Ctrl-C. |
| 502 | if( $this->{'read_buf'} =~ /^$this->{'prompt'}/m ) { |
| 503 | while( $this->{'read_buf'} =~ /^$this->{'prompt'}/m ) { |
| 504 | $this->print_status(8, "MATCHED\n", |
| 505 | "BEFORE: '", _make_readable($`), "'\n", |
| 506 | "PROMPT: '", _make_readable($&), "'\n", |
| 507 | "AFTER: '", _make_readable($'), "'\n"); |
| 508 | $this->{'read_buf'} = $'; |
| 509 | $before = $`; |
| 510 | $before =~ s/(\r|\e.{0,2})//mg; |
| 511 | $this->print_data(3, $before); |
| 512 | $this->{'current_response'} .= $before; |
| 513 | } |
| 514 | $this->{'response_pending'} = 1; |
| 515 | return 1; |
| 516 | |
| 517 | # The pager string is in the data. If the termios stuff is functioning |
| 518 | # properly, I should be able to send a space to advance the pager. |
| 519 | } elsif( $this->{'read_buf'} =~ /\e\[7m--More--\e\[m/ ) { |
| 520 | $this->print_status(8, "MATCHED THE PAGER STRING\n", |
| 521 | "SENDING A SPACE TO ADVANCE THE PAGER.\n", |
| 522 | "BEFORE: '", _make_readable($`), "'\n", |
| 523 | "PROMPT: '", _make_readable($&), "'\n", |
| 524 | "AFTER: '", _make_readable($'), "'\n"); |
| 525 | $before = $`; |
| 526 | $before =~ s/(\r|\e.{0,2})//mg; |
| 527 | $this->print_data(3, $before); |
| 528 | $this->{'$current_response'} .= $before; |
| 529 | $this->write_data(' '); |
| 530 | $this->{'read_buf'} = ''; |
| 531 | return 0; |
| 532 | |
| 533 | # Multiline command detected - this is by no means full proof. |
| 534 | # People shouldn't be entering mlc, just return so they don't hang. |
| 535 | } elsif( $this->{'read_buf'} =~ /^(\? )+/ and $this->{'current_response'} eq '' ) { |
| 536 | $this->print_status(3, "Multiline command detected.\n"); |
| 537 | $this->{'read_buf'} = ''; |
| 538 | return 1; |
| 539 | |
| 540 | # No prompt, just data. |
| 541 | } else { |
| 542 | $this->print_status(9, "NOMATCH\n'", _make_readable($this->{'read_buf'}), "'\n"); |
| 543 | $before = $this->{'read_buf'}; |
| 544 | $before =~ s/(\r|\e.{0,2})//mg; |
| 545 | $this->print_data(3, $before); |
| 546 | $this->{'current_response'} .= $before; |
| 547 | $this->{'read_buf'} = ''; |
| 548 | return 0; |
| 549 | } |
| 550 | } |
| 551 | } |
| 552 | |
| 553 | # |
| 554 | # Private local subroutines that aren't methods are below. Only used by this |
| 555 | # module. |
| 556 | # |
| 557 | |
| 558 | sub _make_readable { |
| 559 | local $_ = shift; |
| 560 | return '' unless defined $_; |
| 561 | s/\\/\\\\/g; |
| 562 | s/\n/\\n/g; |
| 563 | s/\r/\\r/g; |
| 564 | s/\e/\\e/g; |
| 565 | s/\t/\\t/g; |
| 566 | s/\0/\\0/g; |
| 567 | s/\f/\\f/g; |
| 568 | s/([\000-\037\177])/'^' . chr(ord($1)^64)/eg; |
| 569 | s/([\200-\377])/sprintf("\\%3o", ord($1))/eg; |
| 570 | return $_; |
| 571 | } |
| 572 | |
| 573 | sub which { |
| 574 | my $file = shift; |
| 575 | my @dirs; |
| 576 | |
| 577 | if( $file =~ m(^/) ) { |
| 578 | if( -f $file and -x _ ) { |
| 579 | return $file; |
| 580 | } else { |
| 581 | return undef; |
| 582 | } |
| 583 | } elsif( $file =~ m(/) ) { |
| 584 | @dirs = (POSIX::getcwd); |
| 585 | } else { |
| 586 | @dirs = (split ':', $ENV{'PATH'}); |
| 587 | } |
| 588 | |
| 589 | foreach my $dir (@dirs) { |
| 590 | my $path = "$dir/$file"; |
| 591 | return $path if( -f $path and -x _ ); |
| 592 | } |
| 593 | |
| 594 | return undef; |
| 595 | } |
| 596 | |
| 597 | 1; |