home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Channel.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-03  |  9.0 KB  |  318 lines
  1. # $Id: Channel.pm,v 1.18 2003/12/03 15:35:21 autarch Exp $
  2.  
  3. package Net::SSH::Perl::Channel;
  4. use strict;
  5.  
  6. use Net::SSH::Perl::Buffer;
  7. use Net::SSH::Perl::Constants qw( :msg2 :channels );
  8.  
  9. use Carp qw( croak );
  10. use Scalar::Util qw(weaken);
  11.  
  12. sub new {
  13.     my $class = shift;
  14.     my($ssh, $mgr) = (shift, shift);
  15.     my $c = bless { ssh => $ssh, mgr => $mgr, @_ }, $class;
  16.     weaken $c->{ssh};
  17.     weaken $c->{mgr};
  18.     $c->init;
  19.     $ssh->debug("channel $c->{id}: new [$c->{remote_name}]");
  20.     $c;
  21. }
  22.  
  23. sub init {
  24.     my $c = shift;
  25.     $c->{id} = $c->{mgr}->new_channel_id;
  26.     $c->{type} = SSH_CHANNEL_OPENING;
  27.     $c->{input} = Net::SSH::Perl::Buffer->new( MP => 'SSH2' );
  28.     $c->{output} = Net::SSH::Perl::Buffer->new( MP => 'SSH2' );
  29.     $c->{extended} = Net::SSH::Perl::Buffer->new( MP => 'SSH2' );
  30.     $c->{ostate} = CHAN_OUTPUT_OPEN;
  31.     $c->{istate} = CHAN_INPUT_OPEN;
  32.     $c->{flags} = 0;
  33.     $c->{remote_window} = 0;
  34.     $c->{local_window} ||= 32 * 1024;
  35.     $c->{local_window_max} = $c->{local_window};
  36.     $c->{local_consumed} = 0;
  37.     $c->{local_maxpacket} ||= 16 * 1024;
  38.     $c->{ctype} ||= 'session';
  39.     $c->{remote_name} ||= 'client-session';
  40. }
  41.  
  42. sub open {
  43.     my $c = shift;
  44.     my $ssh = $c->{ssh};
  45.     $ssh->debug("Requesting channel_open for channel $c->{id}.");
  46.     my $packet = $ssh->packet_start(SSH2_MSG_CHANNEL_OPEN);
  47.     $packet->put_str($c->{ctype});
  48.     $packet->put_int32($c->{id});
  49.     $packet->put_int32($c->{local_window});
  50.     $packet->put_int32($c->{local_maxpacket});
  51.     $packet->send;
  52. }
  53.  
  54. sub request {
  55.     my $c = shift;
  56.     my $packet = $c->request_start(@_);
  57.     $packet->send;
  58. }
  59.  
  60. sub request_start {
  61.     my $c = shift;
  62.     my($service, $want_reply) = @_;
  63.     my $ssh = $c->{ssh};
  64.     $ssh->debug("Requesting service $service on channel $c->{id}.");
  65.     my $packet = $ssh->packet_start(SSH2_MSG_CHANNEL_REQUEST);
  66.     $packet->put_int32($c->{remote_id});
  67.     $packet->put_str($service);
  68.     $packet->put_int8($want_reply);
  69.     return $packet;
  70. }
  71.  
  72. sub send_data {
  73.     my $c = shift;
  74.     my($buf) = @_;
  75.     $c->{input}->append($buf);
  76. }
  77.  
  78. sub process_outgoing {
  79.     my $c = shift;
  80.     return unless ($c->{istate} == CHAN_INPUT_OPEN ||
  81.                    $c->{istate} == CHAN_INPUT_WAIT_DRAIN) &&
  82.                   $c->{input}->length > 0;
  83.     my $len = $c->{input}->length;
  84.     $len = $c->{remote_window} if $len > $c->{remote_window};
  85.     $len = $c->{remote_maxpacket} if $len > $c->{remote_maxpacket};
  86.     my $data = $c->{input}->bytes(0, $len, '');
  87.     my $packet = $c->{ssh}->packet_start(SSH2_MSG_CHANNEL_DATA);
  88.     $packet->put_int32($c->{remote_id});
  89.     $packet->put_str($data);
  90.     $packet->send;
  91.     $c->{remote_window} -= $len;
  92. }
  93.  
  94. sub check_window {
  95.     my $c = shift;
  96.     if ($c->{type} == SSH_CHANNEL_OPEN &&
  97.        !($c->{flags} & (CHAN_CLOSE_SENT | CHAN_CLOSE_RCVD)) &&
  98.        $c->{local_window} < $c->{local_window_max}/2 &&
  99.        $c->{local_consumed} > 0) {
  100.         my $packet = $c->{ssh}->packet_start(SSH2_MSG_CHANNEL_WINDOW_ADJUST);
  101.         $packet->put_int32($c->{remote_id});
  102.         $packet->put_int32($c->{local_consumed});
  103.         $packet->send;
  104.         $c->{ssh}->debug("channel $c->{id}: window $c->{local_window} sent adjust $c->{local_consumed}");
  105.         $c->{local_window} += $c->{local_consumed};
  106.         $c->{local_consumed} = 0;
  107.     }
  108. }
  109.  
  110. sub prepare_for_select {
  111.     my $c = shift;
  112.     my($rb, $wb) = @_;
  113.     if ($c->{rfd} && $c->{istate} == CHAN_INPUT_OPEN &&
  114.         $c->{remote_window} > 0 &&
  115.         $c->{input}->length < $c->{remote_window}) {
  116.         $rb->add($c->{rfd});
  117.     }
  118.     if ($c->{wfd} &&
  119.         $c->{ostate} == CHAN_OUTPUT_OPEN ||
  120.         $c->{ostate} == CHAN_OUTPUT_WAIT_DRAIN) {
  121.         if ($c->{output}->length > 0) {
  122.             $wb->add($c->{wfd});
  123.         }
  124.         elsif ($c->{ostate} == CHAN_OUTPUT_WAIT_DRAIN &&
  125.                $c->{extended}->length == 0) {
  126.             $c->obuf_empty;
  127.         }
  128.     }
  129.     if ($c->{efd} && $c->{extended}->length > 0) {
  130.         $wb->add($c->{efd});
  131.     }
  132. }
  133.  
  134. sub process_buffers {
  135.     my $c = shift;
  136.     my($rready, $wready) = @_;
  137.  
  138.     my %fd = (output => $c->{wfd}, extended => $c->{efd});
  139.     for my $buf (keys %fd) {
  140.         if ($fd{$buf} && grep { $fd{$buf} == $_ } @$wready) {
  141.             if (my $r = $c->{handlers}{"_${buf}_buffer"}) {
  142.                 $r->{code}->( $c, $c->{$buf}, @{ $r->{extra} } );
  143.             }
  144.             else {
  145.                 #warn "No handler for '$buf' buffer set up";
  146.             }
  147.             $c->{local_consumed} += $c->{$buf}->length
  148.                 if $buf eq "output";
  149.             $c->{$buf}->empty;
  150.         }
  151.     }
  152.  
  153.     if ($c->{rfd} && grep { $c->{rfd} == $_ } @$rready) {
  154.         my $buf;
  155.         sysread $c->{rfd}, $buf, 8192;
  156.         ($buf) = $buf =~ /(.*)/s;
  157.         $c->send_data($buf);
  158.     }
  159. }
  160.  
  161. sub rcvd_ieof {
  162.     my $c = shift;
  163.     $c->{ssh}->debug("channel $c->{id}: rcvd eof");
  164.     if ($c->{ostate} && $c->{ostate} == CHAN_OUTPUT_OPEN) {
  165.         $c->{ssh}->debug("channel $c->{id}: output open -> drain");
  166.         $c->{ostate} = CHAN_OUTPUT_WAIT_DRAIN;
  167.     }
  168. }
  169.  
  170. sub obuf_empty {
  171.     my $c = shift;
  172.     $c->{ssh}->debug("channel $c->{id}: obuf empty");
  173.     if ($c->{output}->length) {
  174.         warn "internal error: obuf_empty $c->{id} for non empty buffer";
  175.         return;
  176.     }
  177.     if ($c->{ostate} == CHAN_OUTPUT_WAIT_DRAIN) {
  178.         $c->{ssh}->debug("channel $c->{id}: output drain -> closed");
  179.         $c->shutdown_write;
  180.         $c->{ostate} = CHAN_OUTPUT_CLOSED;
  181.     }
  182.     else {
  183.         warn "channel $c->{id}: internal error: obuf_empty for ostate $c->{ostate}";
  184.     }
  185. }
  186.  
  187. sub drain_outgoing {
  188.     my $c = shift;
  189.     $c->register_handler(SSH2_MSG_CHANNEL_WINDOW_ADJUST, sub {
  190.         $_[0]->{ssh}->break_client_loop
  191.     });
  192.     while ($c->{input}->length) {
  193.         $c->process_outgoing;
  194.         $c->{ssh}->client_loop if $c->{input}->length;
  195.     }
  196.     $c->drop_handler(SSH2_MSG_CHANNEL_WINDOW_ADJUST);
  197.     $c->{ssh}->restore_client_loop;
  198. }
  199.  
  200. sub shutdown_write {
  201.     my $c = shift;
  202.     $c->{output}->empty;
  203.     return if $c->{type} == SSH_CHANNEL_LARVAL;
  204.     $c->{ssh}->debug("channel $c->{id}: close_write");
  205.  
  206.     ## XXX: have to check for socket ($c->{socket}) and either
  207.     ## do shutdown or close of file descriptor.
  208. }
  209.  
  210. sub delete_if_full_closed {
  211.     my $c = shift;
  212.     if ($c->{istate} == CHAN_INPUT_CLOSED && $c->{ostate} == CHAN_OUTPUT_CLOSED) {
  213.         unless ($c->{flags} & CHAN_CLOSE_SENT) {
  214.             $c->send_close;
  215.         }
  216.         if (($c->{flags} & CHAN_CLOSE_SENT) && ($c->{flags} & CHAN_CLOSE_RCVD)) {
  217.             $c->{ssh}->debug("channel $c->{id}: full closed");
  218.             return 1;
  219.         }
  220.     }
  221.     return 0;
  222. }
  223.  
  224. sub send_close {
  225.     my $c = shift;
  226.     $c->{ssh}->debug("channel $c->{id}: send close");
  227.     if ($c->{ostate} != CHAN_OUTPUT_CLOSED ||
  228.         $c->{istate} != CHAN_INPUT_CLOSED) {
  229.         warn "channel $c->{id}: internal error: cannot send close for istate/ostate $c->{istate}/$c->{ostate}";
  230.     }
  231.     elsif ($c->{flags} & CHAN_CLOSE_SENT) {
  232.         warn "channel $c->{id}: internal error: already sent close";
  233.     }
  234.     else {
  235.         my $packet = $c->{ssh}->packet_start(SSH2_MSG_CHANNEL_CLOSE);
  236.         $packet->put_int32($c->{remote_id});
  237.         $packet->send;
  238.         $c->{flags} |= CHAN_CLOSE_SENT;
  239.     }
  240. }
  241.  
  242. sub rcvd_oclose {
  243.     my $c = shift;
  244.     $c->{ssh}->debug("channel $c->{id}: rcvd close");
  245.     $c->{flags} |= CHAN_CLOSE_RCVD;
  246.     if ($c->{type} == SSH_CHANNEL_LARVAL) {
  247.         $c->{ostate} = CHAN_OUTPUT_CLOSED;
  248.         $c->{istate} = CHAN_INPUT_CLOSED;
  249.         return;
  250.     }
  251.     if ($c->{ostate} == CHAN_OUTPUT_OPEN) {
  252.         $c->{ssh}->debug("channel $c->{id}: output open -> drain");
  253.         $c->{ostate} = CHAN_OUTPUT_WAIT_DRAIN;
  254.     }
  255.     if ($c->{istate} == CHAN_INPUT_OPEN) {
  256.         $c->{ssh}->debug("channel $c->{id}: input open -> closed");
  257.         $c->shutdown_read;
  258.     }
  259.     elsif ($c->{istate} == CHAN_INPUT_WAIT_DRAIN) {
  260.         $c->{ssh}->debug("channel $c->{id}: input drain -> closed");
  261.         $c->send_eof;
  262.     }
  263.     $c->{istate} = CHAN_INPUT_CLOSED;
  264. }
  265.  
  266. sub shutdown_read {
  267.     my $c = shift;
  268.     return if $c->{type} == SSH_CHANNEL_LARVAL;
  269.     $c->{ssh}->debug("channel $c->{id}: close_read");
  270.  
  271.     ## XXX: have to check for socket ($c->{socket}) and either
  272.     ## do shutdown or close of file descriptor.
  273. }
  274.  
  275. sub send_eof {
  276.     my $c = shift;
  277.     $c->{ssh}->debug("channel $c->{id}: send eof");
  278.     if ($c->{istate} == CHAN_INPUT_WAIT_DRAIN) {
  279.         my $packet = $c->{ssh}->packet_start(SSH2_MSG_CHANNEL_EOF);
  280.         $packet->put_int32($c->{remote_id});
  281.         $packet->send;
  282.     }
  283.     else {
  284.         warn "channel $c->{id}: internal error: cannot send eof for istate $c->{istate}";
  285.     }
  286. }
  287.  
  288. sub register_handler {
  289.     my $c = shift;
  290.     my($type, $sub, @extra) = @_;
  291.     $c->{handlers}{$type} = { code => $sub, extra => \@extra };
  292. }
  293.  
  294. sub drop_handler { delete $_[0]->{handlers}{$_[1]} }
  295.  
  296. 1;
  297. __END__
  298.  
  299. =head1 NAME
  300.  
  301. Net::SSH::Perl::Channel - SSH2 channel object
  302.  
  303. =head1 SYNOPSIS
  304.  
  305.     use Net::SSH::Perl::Channel;
  306.  
  307. =head1 DESCRIPTION
  308.  
  309. I<Net::SSH::Perl::Channel> implements a channel object compatible
  310. with the SSH2 channel mechanism.
  311.  
  312. =head1 AUTHOR & COPYRIGHTS
  313.  
  314. Please see the Net::SSH::Perl manpage for author, copyright,
  315. and license information.
  316.  
  317. =cut
  318.