File Coverage

blib/lib/App/pnc.pm
Criterion Covered Total %
statement 18 77 23.3
branch 0 34 0.0
condition 0 15 0.0
subroutine 6 11 54.5
pod 0 4 0.0
total 24 141 17.0


line stmt bran cond sub pod time code
1             package App::pnc;
2              
3             our $VERSION = '0.02';
4              
5 1     1   23060 use strict;
  1         3  
  1         44  
6 1     1   5 use warnings;
  1         3  
  1         42  
7              
8 1     1   914 use Socket;
  1         3829  
  1         532  
9 1     1   7 use Carp;
  1         2  
  1         45  
10 1     1   4 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
  1         2  
  1         39  
11 1     1   683 use Errno qw(ENOTSOCK);
  1         1222  
  1         916  
12              
13             our $max_buffer_size = 64 * 1024;
14              
15             require Exporter;
16             our @ISA = qw(Exporter);
17             our @EXPORT_OK = qw(netcat4 netcat_socket);
18              
19             sub netcat4 {
20 0     0 0   my ($server, $port) = @_;
21 0 0         if ($port =~ /\D/) {
22 0 0         $port = getservbyname($port, 'tcp')
23             or croak "unable to convert service name to port number: $!";
24             }
25 0 0         my $iaddr = inet_aton($server) or croak "unable to resolve host name: $!";
26 0           my $paddr = sockaddr_in($port, $iaddr);
27 0 0         socket (my $socket, AF_INET, SOCK_STREAM, 0) or croak "unable to create socket: $!";
28 0 0         connect ($socket, $paddr) or croak "unable to connect to host: $!";
29              
30 0           netcat_socket($socket);
31             }
32              
33             sub netcat6 {
34             #my ($server, $port) = @_;
35             #netcat_socket($server, AF_INET6, $port);
36 0     0 0   croak "not implemented yet!";
37             }
38              
39             sub _shutdown {
40 0     0     my ($socket, $dir) = @_;
41 0 0         unless (shutdown($socket, $dir)) {
42 0 0         if ($! == ENOTSOCK) {
43 0           return close ($socket);
44             }
45             }
46 0           undef;
47             }
48              
49             sub netcat_socket {
50 0     0 0   my $socket = shift;
51              
52 0           for my $fh ($socket, *STDIN, *STDOUT) {
53 0           my $flags = fcntl($fh, F_GETFL, 0);
54 0           fcntl($fh, F_SETFL, fcntl($fh, F_GETFL, 0) | O_NONBLOCK);
55 0           binmode $fh;
56             }
57              
58 0           my @in = (*STDIN, $socket);
59 0           my @out = ($socket, *STDOUT);
60 0           my @buffer = ('', '');
61              
62 0           my @in_open = (1, 1);
63 0           my @out_open = (1, 1);
64              
65 0           local $SIG{PIPE} = 'IGNORE';
66              
67 0           while (grep $_, @in_open, @out_open) {
68 0           my $iv = '';
69 0           my $ov = '';
70 0           for my $ix (0, 1) {
71 0 0 0       if ($in_open[$ix] and length $buffer[$ix] < $max_buffer_size) {
72 0           vec($iv, fileno($in[$ix]), 1) = 1;
73             }
74 0 0 0       if ($out_open[$ix] and length $buffer[$ix] > 0) {
75 0           vec($ov, fileno($out[$ix]), 1) = 1;
76             }
77             }
78 0 0         if (select($iv, $ov, undef, 5) > 0) {
79 0           for my $ix (0, 1) {
80 0 0 0       if ($in_open[$ix] and vec($iv, fileno($in[$ix]), 1)) {
81 0           my $bytes = sysread($in[$ix], $buffer[$ix], 16 * 1024, length $buffer[$ix]);
82 0 0         unless ($bytes) {
83 0           $in_open[$ix] = 0;
84 0           _shutdown($in[$ix], 0);
85 0 0         unless (length $buffer[$ix]) {
86 0           $out_open[$ix] = 0;
87 0           _shutdown($out[$ix], 1);
88             }
89             }
90             }
91 0 0 0       if ($out_open[$ix] and vec($ov, fileno($out[$ix]), 1)) {
92 0           my $bytes = syswrite($out[$ix], $buffer[$ix], 16 * 1024);
93 0 0         if ($bytes) {
94 0           substr($buffer[$ix], 0, $bytes, '');
95 0 0 0       unless ($in_open[$ix] or length $buffer[$ix]) {
96 0           $out_open[$ix] = 0;
97 0           _shutdown($out[$ix], 1);
98             }
99             }
100             else {
101 0           $out_open[$ix] = 0;
102 0           _shutdown($out[$ix], 1);
103 0           $buffer[$ix] = '';
104 0 0         if ($in_open[$ix]) {
105 0           $in_open[$ix] = 0;
106 0           _shutdown($in[$ix], 0);
107             }
108             }
109             }
110             }
111             }
112             }
113 0           for my $fd ($socket, *STDIN, *STDOUT) {
114 0           close $fd;
115             }
116             }
117              
118 0     0 0   sub version { "pnc $VERSION - a netcat alike program written in Perl\n\n" }
119              
120             unless (defined caller) {
121             if (@ARGV == 1 and $ARGV[0] eq '-V') {
122             print version();
123             }
124             elsif (@ARGV == 2) {
125             netcat4(@ARGV);
126             }
127             else {
128             @ARGV == 2 or die "Usage:\n pnc host port\n\n";
129             }
130             }
131              
132              
133             1;
134              
135             __END__