Games-Axmud

 view release on metacpan or  search on metacpan

lib/Games/Axmud/Obj/Telnet.pm  view on Meta::CPAN

        while ($remove_echo--) {
        shift @$output;
        }

        ## Ensure at least a null string when there's no command output - so
        ## "true" is returned in a list context.
        unless (@$output) {
        @$output = ("");
        }

        ## Return command output via named arg, if requested.
        if (defined $output_ref) {
        if (ref($output_ref) eq "SCALAR") {
            $$output_ref = join "", @$output;
        }
        elsif (ref($output_ref) eq "HASH") {
            %$output_ref = @$output;
        }
        }

        wantarray ? @$output : 1;
    } # end sub cmd


    sub cmd_remove_mode {
        my ($self, $mode) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{cmd_rm_mode};

        if (@_ >= 2) {
        $s->{cmd_rm_mode} = &_parse_cmd_remove_mode($self, $mode);
        }

        $prev;
    } # end sub cmd_remove_mode


    sub dump_log {
        my ($self, $name) = @_;
        my (
        $fh,
        $s,
        );

        $s = *$self->{net_telnet};
        $fh = $s->{dumplog};

        if (@_ >= 2) {
        if (!defined($name) or $name eq "") {  # input arg is ""
            ## Turn off logging.
            $fh = "";
        }
        elsif (&_is_open_fh($name)) {  # input arg is an open fh
            ## Use the open fh for logging.
            $fh = $name;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        elsif (!ref $name) {  # input arg is filename
            ## Open the file for logging.
            $fh = &_fname_to_handle($self, $name)
            or return;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        else {
            return $self->error("bad Dump_log argument ",
                    "\"$name\": not filename or open fh");
        }

        $s->{dumplog} = $fh;
        }

        $fh;
    } # end sub dump_log


    sub eof {
        my ($self) = @_;

        *$self->{net_telnet}{eofile};
    } # end sub eof


    sub errmode {
        my ($self, $mode) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{errormode};

        if (@_ >= 2) {
        $s->{errormode} = &_parse_errmode($self, $mode);
        }

        $prev;
    } # end sub errmode


    sub errmsg {
        my ($self, @errmsgs) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{errormsg};

        if (@_ >= 2) {
        $s->{errormsg} = join "", @errmsgs;
        }

        $prev;
    } # end sub errmsg


    sub error {
        my ($self, @errmsg) = @_;
        my (
        $errmsg,

lib/Games/Axmud/Obj/Telnet.pm  view on Meta::CPAN

            else {
            ## Die and append caller's line number to message.
            &_croak($self, $errmsg);
            }
        }
        }
        else {
        return $s->{errormsg} ne "";
        }
    } # end sub error


    sub family {
        my ($self, $family) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{peer_family};

        if (@_ >= 2) {
        $family = &_parse_family($self, $family)
            or return;

        $s->{peer_family} = $family;
        }

        $prev;
    } # end sub family


    sub fhopen {
        my ($self, $fh) = @_;
        my (
        $globref,
        $s,
        );

        ## Convert given filehandle to a typeglob reference, if necessary.
        $globref = &_qualify_fh($self, $fh);

        ## Ensure filehandle is already open.
        return $self->error("fhopen filehandle isn't already open")
        unless defined($globref) and defined(fileno $globref);

        ## Ensure we're closed.
        $self->close;

        ## Save our private data.
        $s = *$self->{net_telnet};

        ## Switch ourself with the given filehandle.
        *$self = *$globref;

        ## Restore our private data.
        *$self->{net_telnet} = $s;

        ## Re-initialize ourself.
        select((select($self), $|=1)[$[]);  # don't buffer writes
        $s = *$self->{net_telnet};
        $s->{blksize} = &_optimal_blksize((stat $self)[11]);
        $s->{buf} = "";
        $s->{eofile} = '';
        $s->{errormsg} = "";
        vec($s->{fdmask}='', fileno($self), 1) = 1;
        $s->{host} = "";
        $s->{last_line} = "";
        $s->{last_prompt} = "";
        $s->{num_wrote} = 0;
        $s->{opened} = 1;
        $s->{pending_errormsg} = "";
        $s->{port} = '';
        $s->{pushback_buf} = "";
        $s->{select_supported} = $^O ne "MSWin32" || -S $self;
        $s->{timedout} = '';
        $s->{unsent_opts} = "";
        &_reset_options($s->{opts});

        1;
    } # end sub fhopen


    sub get {
        my ($self, %args) = @_;
        my (
        $binmode,
        $endtime,
        $errmode,
        $line,
        $s,
        $telnetmode,
        $timeout,
        );
        local $_;

        ## Init.
        $s = *$self->{net_telnet};
        $timeout = $s->{time_out};
        $s->{timedout} = '';
        return if $s->{eofile};

        ## Parse the named args.
        foreach (keys %args) {
        if (/^-?binmode$/i) {
            $binmode = $args{$_};
            unless (defined $binmode) {
            $binmode = 0;
            }
        }
        elsif (/^-?errmode$/i) {
            $errmode = &_parse_errmode($self, $args{$_});
        }
        elsif (/^-?telnetmode$/i) {
            $telnetmode = $args{$_};
            unless (defined $telnetmode) {
            $telnetmode = 0;
            }
        }
        elsif (/^-?timeout$/i) {

lib/Games/Axmud/Obj/Telnet.pm  view on Meta::CPAN

        ## User requested only the currently available lines.
        if (! $all) {
        return &_next_getlines($self, $s);
        }

        ## Read lines until eof or error.
        while (1) {
        $line = $self->getline
            or last;
        push @lines, $line;
        }

        ## Check for error.
        return if ! $self->eof;

        @lines;
    } # end sub getlines


    sub host {
        my ($self, $host) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{host};

        if (@_ >= 2) {
        unless (defined $host) {
            $host = "";
        }

        $s->{host} = $host;
        }

        $prev;
    } # end sub host


    sub input_log {
        my ($self, $name) = @_;
        my (
        $fh,
        $s,
        );

        $s = *$self->{net_telnet};
        $fh = $s->{inputlog};

        if (@_ >= 2) {
        if (!defined($name) or $name eq "") {  # input arg is ""
            ## Turn off logging.
            $fh = "";
        }
        elsif (&_is_open_fh($name)) {  # input arg is an open fh
            ## Use the open fh for logging.
            $fh = $name;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        elsif (!ref $name) {  # input arg is filename
            ## Open the file for logging.
            $fh = &_fname_to_handle($self, $name)
            or return;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        else {
            return $self->error("bad Input_log argument ",
                    "\"$name\": not filename or open fh");
        }

        $s->{inputlog} = $fh;
        }

        $fh;
    } # end sub input_log


    sub input_record_separator {
        my ($self, $rs) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{"rs"};

        if (@_ >= 2) {
        $s->{"rs"} = &_parse_input_record_separator($self, $rs);
        }

        $prev;
    } # end sub input_record_separator


    sub last_prompt {
        my ($self, $string) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{last_prompt};

        if (@_ >= 2) {
        unless (defined $string) {
            $string = "";
        }

        $s->{last_prompt} = $string;
        }

        $prev;
    } # end sub last_prompt


    sub lastline {
        my ($self, $line) = @_;
        my (
        $prev,
        $s,
        );

lib/Games/Axmud/Obj/Telnet.pm  view on Meta::CPAN

            $remote_addr = sockaddr_in($port, $ip_addr);
        }
        else {  # family is "ipv6" or "any"
            ## Lookup server's IP address.
            $flags_hint = $family eq "any" ? $AI_ADDRCONFIG : 0;
            ($err, @ai) = Socket::getaddrinfo($host, $port,
                              { socktype => SOCK_STREAM,
                            "family" => $af{$family},
                            "flags" => $flags_hint });
            if ($err == $EAI_BADFLAGS) {
            ## Try again with no flags.
            ($err, @ai) = Socket::getaddrinfo($host, $port,
                              { socktype => SOCK_STREAM,
                                "family"=> $af{$family},
                                "flags" => 0 });
            }
            return $self->error("unknown remote host: $host")
            if $err or !@ai;
            $af = $ai[0]{"family"};
            $remote_addr = $ai[0]{addr};
        }

        ## Create a socket and attach the filehandle to it.
        socket $self, $af, SOCK_STREAM, 0
            or return $self->error("problem creating socket: $!");

        ## Bind to a local network interface.
        if (length $localhost) {
            if ($lfamily eq "ipv4") {
            ## Lookup server's IP address.
            $ip_addr = inet_aton $localhost
                or return $self->error("unknown local host: $localhost");
            $local_addr = sockaddr_in(0, $ip_addr);
            }
            else {  # local family is "ipv6" or "any"
            ## Lookup local IP address.
            ($err, @ai) = Socket::getaddrinfo($localhost, 0,
                              { socktype => SOCK_STREAM,
                                "family"=>$af{$lfamily},
                                "flags" => 0 });
            return $self->error("unknown local host: $localhost: $err")
                if $err or !@ai;
            $local_addr = $ai[0]{addr};
            }

            bind $self, $local_addr
            or return $self->error("problem binding ",
                           "to \"$localhost\": $!");
        }

        ## Open connection to server.
        connect $self, $remote_addr
            or do {
            $errno = "$!";
            $self->close;
            return $self->error("problem connecting to \"$host\", ",
                        "port $port: $errno");
            };
        }

        select((select($self), $|=1)[$[]);  # don't buffer writes
        $s->{blksize} = &_optimal_blksize((stat $self)[11]);
        $s->{buf} = "";
        $s->{eofile} = '';
        $s->{errormsg} = "";
        vec($s->{fdmask}='', fileno($self), 1) = 1;
        $s->{last_line} = "";
        $s->{sock_family} = $af;
        $s->{num_wrote} = 0;
        $s->{opened} = 1;
        $s->{pending_errormsg} = "";
        $s->{pushback_buf} = "";
        $s->{select_supported} = 1;
        $s->{timedout} = '';
        $s->{unsent_opts} = "";
        &_reset_options($s->{opts});

        1;
    } # end sub open


    sub option_accept {
        my ($self, @args) = @_;
        my (
        $arg,
        $option,
        $s,
        @opt_args,
        );
        local $_;

        ## Init.
        $s = *$self->{net_telnet};

        ## Parse the named args.
        while (($_, $arg) = splice @args, 0, 2) {
        ## Verify and save arguments.
        if (/^-?do$/i) {
            ## Make sure a callback is defined.
            return $self->error("usage: an option callback must already ",
                    "be defined when enabling with $_")
            unless $s->{opt_cback};

            $option = &_verify_telopt_arg($self, $arg, $_);
            return unless defined $option;
            push @opt_args, { option    => $option,
                      is_remote => '',
                      is_enable => 1,
                  };
        }
        elsif (/^-?dont$/i) {
            $option = &_verify_telopt_arg($self, $arg, $_);
            return unless defined $option;
            push @opt_args, { option    => $option,
                      is_remote => '',
                      is_enable => '',
                  };
        }
        elsif (/^-?will$/i) {
            ## Make sure a callback is defined.
            return $self->error("usage: an option callback must already ",

lib/Games/Axmud/Obj/Telnet.pm  view on Meta::CPAN

                      is_remote => 1,
                      is_enable => '',
                  };
        }
        else {
            return $self->error('usage: $obj->option_accept(' .
                    '[Do => $telopt,] ',
                    '[Dont => $telopt,] ',
                    '[Will => $telopt,] ',
                    '[Wont => $telopt,]');
        }
        }

        ## Set "receive ok" for options specified.
        &_opt_accept($self, @opt_args);
    } # end sub option_accept


    sub option_callback {
        my ($self, $callback) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{opt_cback};

        if (@_ >= 2) {
        unless (defined $callback and ref($callback) eq "CODE") {
            &_carp($self, "ignoring Option_callback argument because it's " .
               "not a code ref");
            $callback = $prev;
        }

        $s->{opt_cback} = $callback;
        }

        $prev;
    } # end sub option_callback


    sub option_log {
        my ($self, $name) = @_;
        my (
        $fh,
        $s,
        );

        $s = *$self->{net_telnet};
        $fh = $s->{opt_log};

        if (@_ >= 2) {
        if (!defined($name) or $name eq "") {  # input arg is ""
            ## Turn off logging.
            $fh = "";
        }
        elsif (&_is_open_fh($name)) {  # input arg is an open fh
            ## Use the open fh for logging.
            $fh = $name;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        elsif (!ref $name) {  # input arg is filename
            ## Open the file for logging.
            $fh = &_fname_to_handle($self, $name)
            or return;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        else {
            return $self->error("bad Option_log argument ",
                    "\"$name\": not filename or open fh");
        }

        $s->{opt_log} = $fh;
        }

        $fh;
    } # end sub option_log


    sub option_state {
        my ($self, $option) = @_;
        my (
        $opt_state,
        $s,
        %opt_state,
        );

        ## Ensure telnet option is non-negative integer.
        $option = &_verify_telopt_arg($self, $option);
        return unless defined $option;

        ## Init.
        $s = *$self->{net_telnet};
        unless (defined $s->{opts}{$option}) {
        &_set_default_option($s, $option);
        }

        ## Return hashref to a copy of the values.
        $opt_state = $s->{opts}{$option};
        %opt_state = %$opt_state;
        \%opt_state;
    } # end sub option_state


    ## Make ors() synonymous with output_record_separator().
    sub ors { &output_record_separator; }


    sub output_field_separator {
        my ($self, $ofs) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{"ofs"};

        if (@_ >= 2) {
        unless (defined $ofs) {
            $ofs = "";
        }

        $s->{"ofs"} = $ofs;
        }

        $prev;
    } # end sub output_field_separator


    sub output_log {
        my ($self, $name) = @_;
        my (
        $fh,
        $s,
        );

        $s = *$self->{net_telnet};
        $fh = $s->{outputlog};

        if (@_ >= 2) {
        if (!defined($name) or $name eq "") {  # input arg is ""
            ## Turn off logging.
            $fh = "";
        }
        elsif (&_is_open_fh($name)) {  # input arg is an open fh
            ## Use the open fh for logging.
            $fh = $name;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        elsif (!ref $name) {  # input arg is filename
            ## Open the file for logging.
            $fh = &_fname_to_handle($self, $name)
            or return;
            select((select($fh), $|=1)[$[]);  # don't buffer writes
        }
        else {
            return $self->error("bad Output_log argument ",
                    "\"$name\": not filename or open fh");
        }

        $s->{outputlog} = $fh;
        }

        $fh;
    } # end sub output_log


    sub output_record_separator {
        my ($self, $ors) = @_;
        my (
        $prev,
        $s,
        );

        $s = *$self->{net_telnet};
        $prev = $s->{"ors"};

        if (@_ >= 2) {
        unless (defined $ors) {
            $ors = "";
        }

        $s->{"ors"} = $ors;
        }

        $prev;
    } # end sub output_record_separator


    sub peerhost {
        my ($self) = @_;
        my (
        $host,
        $sockaddr,
        );
        local $^W = '';  # avoid closed socket warning from getpeername()

        ## Get packed sockaddr struct of remote side and then unpack it.
        $sockaddr = getpeername $self
        or return "";
        (undef, $host) = $self->_unpack_sockaddr($sockaddr);

        $host;
    } # end sub peerhost


    sub peerport {
        my ($self) = @_;
        my (
        $port,
        $sockaddr,
        );
        local $^W = '';  # avoid closed socket warning from getpeername()