TAO/tests/Bug_2678_Regression/dribble.pl

   1 eval '(exit $?0)' && eval 'exec perl -w -S $0 ${1+"$@"}'
   2     & eval 'exec perl -w -S $0 $argv:q'
   3     if 0;
   4
   5 # ******************************************************************
   6 #      Author: Chris Cleeland
   7 #        Date: 10/26/2002
   8 # ******************************************************************
   9
  10 use Getopt::Long;
  11 use File::Basename;
  12 use IO::Socket::INET;
  13 use IO::File;
  14 use Carp;
  15
  16 sub getnum {
  17   use POSIX qw(strtoul);
  18   my $str = shift;
  19   $str =~ s/^\s+//;
  20   $str =~ s/\s+$//;
  21   $! = 0;
  22   my($num, $unparsed) = strtoul($str);
  23   if (($str eq '') || ($unparsed != 0) || $!) {
  24     return undef;
  25   } else {
  26     return $num;
  27   }
  28 }
  29
  30 my $corba_server_addr = "127.0.0.1";
  31 my $corba_server_port = 12345;
  32 my $progress_interval = 10;
  33 my $verbosity = 0;
  34 my $interactive = undef;
  35 my $datastreamfile = 'datastream.dat';
  36 my $dataxmitlayoutfile = undef;
  37 my $delay = .25;
  38
  39 my %options = ('host|h=s'             => \$corba_server_addr,
  40                'port|p=s'             => \$corba_server_port,
  41                'interval|i=i'         => \$progress_interval,
  42                'verbose|verbosity|v+' => \$verbosity,
  43                'interactive'          => \$interactive,
  44                'stream|s=s'           => \$datastreamfile,
  45                'layout|l=s'           => \$dataxmitlayoutfile,
  46                'delay|d=f'            => \$delay,
  47               );
  48 my $result = GetOptions (%options);
  49
  50 if (!$result) {
  51   my($str)     = 'Usage: ' . basename($0);
  52   my($initial) = length($str);
  53   my($length)  = $initial;
  54   my($maxLine) = 78;
  55
  56   print $str;
  57
  58   foreach my $key (sort keys %options) {
  59     my($opt, $type) = split(/[|=]/, $key);
  60     my($str) = " [--$opt" . (defined $type ? " <$opt>" : "") . "]";
  61     my($len) = length($str);
  62     if ($length + $len > $maxLine) {
  63       print "\n" . (" " x $initial);
  64       $length = $initial;
  65     }
  66     print $str;
  67     $length += $len;
  68   }
  69   print "\n";
  70   exit(0);
  71 }
  72
  73 croak "Must supply a data file using --stream and a layout file using --layout"
  74   unless defined $datastreamfile && defined $dataxmitlayoutfile;
  75
  76 my $sock = IO::Socket::INET->new(PeerAddr => $corba_server_addr,
  77                                  PeerPort => $corba_server_port,
  78                                  Proto    => 'tcp')
  79   or croak "Unable to establish connection to $corba_server_addr:$corba_server_port: $!\n";
  80
  81 #
  82 # Infer a name for the layout file
  83 #
  84 if (! defined $dataxmitlayoutfile) {
  85   $dataxmitlayoutfile = $datastreamfile;
  86   $dataxmitlayoutfile =~ s/\.dat$/\.layout/;
  87 }
  88
  89 # Now we just start reading from <> and writing to the socket We
  90 # currently assume all are oneways, so we don't worry about reading
  91 # from the socket.
  92
  93 my $stream = new IO::File $datastreamfile, "r"
  94   or croak "Unable to open $datastreamfile for reading: $!";
  95 my $layout = new IO::File $dataxmitlayoutfile, "r"
  96   or croak "Unable to open $dataxmitlayoutfile for reading: $!";
  97
  98 $| = 1;
  99 print "Sending...(1 dot every $progress_interval hunks)\n";
 100 print "Hit <RETURN> key to send a packet\n" if defined $interactive;
 101 my $numread;
 102 do {
 103
 104   #
 105   # Determine the size of the hunk we have to read/send
 106   #
 107   $_ = $layout->getline;
 108   s/#.*$//;
 109   chomp $_;
 110   next if ($_ =~ /^\s*$/);
 111
 112   my $requested_hunksize = getnum($_);
 113   my $l = $layout->input_line_number;
 114
 115   my $hunk;
 116
 117   #
 118   # Read in the hunk size we want
 119   #
 120   $numread = $stream->sysread($hunk, $requested_hunksize);
 121   if (! defined $numread) {
 122     carp "\nHunk $l: Error reading from stream: $!";
 123     next;
 124   }
 125   elsif ($numread != $requested_hunksize) {
 126     carp "\nHunk $l: short read (expected $requested_hunksize, got $numread); going on.";
 127   }
 128
 129   print "Hunk $l: length ", length($hunk), "\n" if ($verbosity >= 1);
 130   if (defined $interactive) {
 131     <STDIN>;
 132   }
 133   else {
 134     select(undef, undef, undef, $delay);
 135   }
 136
 137   my $ret = $sock->send($hunk, 0);
 138   if ($ret != length($hunk)) {
 139     carp "\nHunk $l: problem sending hunk $.: $!\n";
 140     exit(1);
 141   }
 142
 143   print "." if ($. % $progress_interval == 0);
 144 } until $numread == 0 || $layout->eof;
 145 print "\nDone.\n";
 146
 147 ## Sleep 1 second to allow the socket on Windows to get flushed
 148 ## before it's destroyed and this process exits.
 149 sleep(1);