home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Database Designers / Rational Rose 2000 / Rational Setup.EXE / common / lib / network.pl < prev    next >
Encoding:
Perl Script  |  1998-07-24  |  5.6 KB  |  212 lines
  1. ##
  2. ## Jeffrey Friedl (jfriedl@omron.co.jp)
  3. ## Copyri.... ah hell, just take it.
  4. ##
  5. ## July 1994
  6. ##
  7. package network;
  8. $version = "950311.5";
  9.  
  10. ## version 950311.5 -- turned off warnings when requiring 'socket.ph';
  11. ## version 941028.4 -- some changes to quiet perl5 warnings.
  12. ## version 940826.3 -- added check for "socket.ph", and alternate use of
  13. ## socket STREAM value for SunOS5.x
  14. ##
  15.  
  16. ## BLURB:
  17. ## A few simple and easy-to-use routines to make internet connections. 
  18. ## Similar to "chat2.pl" (but actually commented, and a bit more portable).
  19. ## Should work even on SunOS5.x.
  20. ##
  21.  
  22. ##>
  23. ##
  24. ## connect_to() -- make an internet connection to a server.
  25. ##
  26. ## Two uses:
  27. ##    $error = &network'connect_to(*FILEHANDLE, $fromsockaddr, $tosockaddr)
  28. ##      $error = &network'connect_to(*FILEHANDLE, $hostname, $portnum)
  29. ##
  30. ## Makes the given connection and returns an error string, or undef if
  31. ## no error.
  32. ##
  33. ## In the first form, FROMSOCKADDR and TOSOCKADDR are of the form returned
  34. ## by SOCKET'GET_ADDR and SOCKET'MY_ADDR.
  35. ##
  36. ##<
  37. sub connect_to
  38. {
  39.     local(*FD, $arg1, $arg2) = @_;
  40.     local($from, $to)   = ($arg1, $arg2); ## for one interpretation.
  41.     local($host, $port) = ($arg1, $arg2); ## for the other
  42.  
  43.     if (defined($to) && length($from)==16 && length($to)==16) {
  44.     ## ok just as is
  45.     } elsif (defined($host)) {
  46.     $to = &get_addr($host, $port);
  47.     return qq/unknown address "$host"/ unless defined $to;
  48.     $from = &my_addr;
  49.     } else {
  50.     return "unknown arguments to network'connect_to";
  51.     }
  52.  
  53.     return "connect_to failed (socket: $!)"  unless &my_inet_socket(*FD);
  54.     return "connect_to failed (bind: $!)"    unless bind(FD, $from);
  55.     return "connect_to failed (connect: $!)" unless connect(FD, $to);
  56.     local($old) = select(FD); $| = 1; select($old);
  57.     undef;
  58. }
  59.  
  60.  
  61.  
  62. ##>
  63. ##
  64. ## listen_at() - used by a server to indicate that it will accept requests
  65. ##               at the port number given.
  66. ##
  67. ## Used as
  68. ##    $error = &network'listen_at(*LISTEN, $portnumber);
  69. ## (returns undef upon success)
  70. ##
  71. ## You can then do something like
  72. ##     $addr = accept(REMOTE, LISTEN);
  73. ##     print "contact from ", &network'addr_to_ascii($addr), ".\n";
  74. ##     while (<REMOTE>) {
  75. ##        .... process request....
  76. ##     }
  77. ##     close(REMOTE);
  78. ##
  79. ##<
  80. sub listen_at
  81. {
  82.     local(*FD, $port) = @_;
  83.     local($empty) = pack('S n a4 x8', 2 ,$port, "\0\0\0\0");
  84.     return "listen_for failed (socket: $!)"  unless &my_inet_socket(*FD);
  85.     return "listen_for failed (bind: $!)"    unless bind(FD, $empty);
  86.     return "listen_for failed (listen: $!)"  unless listen(FD, 5);
  87.     local($old) = select(FD); $| = 1; select($old);
  88.     undef;
  89. }
  90.  
  91.  
  92. ##>
  93. ##
  94. ## Given an internal packed internet address (as returned by &connect_to
  95. ## or &get_addr), return a printable ``1.2.3.4'' version.
  96. ##
  97. ##<
  98. sub addr_to_ascii
  99. {
  100.     local($addr) = @_;
  101.     return "bad arg" if length $addr != 16;
  102.     return join('.', unpack("CCCC", (unpack('S n a4 x8', $addr))[2]));
  103. }
  104.  
  105. ##
  106. ## 
  107. ## Given a host and a port name, returns the packed socket addresss.
  108. ## Mostly for internal use.
  109. ##
  110. ##
  111. sub get_addr
  112. {
  113.     local($host, $port) = @_;
  114.     return $addr{$host,$port} if defined $addr{$host,$port};
  115.     local($addr);
  116.  
  117.     if ($host =~ m/^\d+\.\d+\.\d+\.\d+$/)
  118.     {
  119.     $addr = pack("C4", split(/\./, $host));
  120.     }
  121.     elsif ($addr = (gethostbyname($host))[4], !defined $addr)
  122.     {
  123.         local(@lookup) = `nslookup $host 2>&1`;
  124.     if (@lookup)
  125.     {
  126.         local($lookup) = join('', @lookup[2 .. $#lookup]);
  127.         if ($lookup =~ m/^Address:\s*(\d+\.\d+\.\d+\.\d+)/) {
  128.             $addr = pack("C4", split(/\./, $1));
  129.         }
  130.     }
  131.     if (!defined $addr) {
  132.         ## warn "$host: SOL, dude\n";
  133.         return undef;
  134.     }
  135.     }
  136.     $addr{$host,$port} = pack('S n a4 x8', 2 ,$port, $addr);
  137. }
  138.  
  139.  
  140. ##
  141. ## my_addr()
  142. ## Returns the packed socket address of the local host (port 0)
  143. ## Mostly for internal use.
  144. ##
  145. ##
  146. sub my_addr
  147. {
  148.     local(@x) = gethostbyname('localhost');
  149.     local(@y) = gethostbyname($x[0]);
  150. #    local($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($x[0]);
  151. #    local(@bytes) = unpack("C4",$addrs[0]);
  152. #        return pack('S n a4 x8', 2 ,0, $addr);
  153.         return pack('S n a4 x8', 2 ,0, $y[4]);
  154. }
  155.  
  156.  
  157. ##
  158. ## my_inet_socket(*FD);
  159. ##
  160. ## Local routine to do socket(PF_INET, SOCK_STREAM, AF_NS).
  161. ## Takes care of figuring out the proper values for the args. Hopefully.
  162. ##
  163. ## Returns the same value as 'socket'.
  164. ##
  165. sub my_inet_socket
  166. {
  167.     local(*FD) = @_;
  168.     local($socket);
  169.  
  170.     if (!defined $socket_values_queried)
  171.     {
  172.     ## try to load some "socket.ph"
  173.     if (!defined &main'_SYS_SOCKET_H_) {
  174.       eval 'package main;
  175.             local($^W) = 0;
  176.                 require("sys/socket.ph")||require("socket.ph");';
  177.     }
  178.  
  179.     ## we'll use "the regular defaults" if for PF_INET and AF_NS if unknown
  180.     $PF_INET     = defined &main'PF_INET ? &main'PF_INET : 2;
  181.     $AF_NS       = defined &main'AF_NS   ? &main'AF_NS   : 6;
  182.     $SOCK_STREAM = &main'SOCK_STREAM if defined &main'SOCK_STREAM;
  183.  
  184.     $socket_values_queried = 1;
  185.     }
  186.  
  187.     if (defined $SOCK_STREAM) {
  188.     $socket = socket(FD, $PF_INET, $SOCK_STREAM, $AF_NS);
  189.     } else {
  190.     ##
  191.     ## We'll try the "regular default" of 1. If that returns a
  192.     ## "not supported" error, we'll try 2, which SunOS5.x uses.
  193.     ##
  194.     $socket = socket(FD, $PF_INET, 1, $AF_NS);
  195.     if ($socket) {
  196.         $SOCK_STREAM = 1; ## got it.
  197.     } elsif ($! =~ m/not supported/i) {
  198.         ## we'll just assume from now on that it's 2.
  199.         $socket = socket(FD, $PF_INET, $SOCK_STREAM = 2, $AF_NS);
  200.     }
  201.     }
  202.     $socket;
  203. }
  204.  
  205. ## This here just to quiet -w warnings.
  206. sub dummy {
  207.   1 || $version || &dummy;
  208. }
  209.  
  210. 1;
  211. __END__
  212.