File Coverage

blib/lib/Net/Raccdoc.pm

Criterion	Covered	Total	%
statement	16	234	6.8
branch	1	90	1.1
condition	2	19	10.5
subroutine	4	18	22.2
pod	14	15	93.3
total	37	376	9.8

package Net::Raccdoc;
$VERSION = "1.3";
require IO::Socket::INET;
use strict;
use warnings;
use Carp;

sub new {
    my ( $class, %arg ) = @_;

    my $host = $arg{host} || "bbs.iscabbs.com";
    my $port = $arg{port} || "6145";
    my $login    = $arg{login};
    my $password = $arg{password};
    my $loggedin = 0;

    my $socket = IO::Socket::INET->new(
        PeerAddr => $host,
        PeerPort => $port,
        Proto    => "tcp",
        Type     => IO::Socket::INET::SOCK_STREAM()
    ) or return;

    my $welcome = <$socket>;
    if ( $welcome !~ /^2/ ) {
        $@ = "Server connection failed with response $welcome";
        return;
    }

    if ( $login && $password ) {
        print $socket "LOGIN $login\t$password\n";
        my $answer = <$socket>;
        if ( $answer =~ /^2/ ) {
            $loggedin = 1;
        }
        else {
            $@ = "LOGIN command failed with response $answer";
            return;
        }
    }

    bless {
        _host     => $host,
        _port     => $port,
        _socket   => $socket,
        _loggedin => $loggedin,
    }, $class;
}

sub forums {
    my $self   = shift;
    my $type   = shift || "all";
    my $socket = $self->{_socket};
    my %forums = ();
    print $socket "LIST $type\n";
    my $status = <$socket>;
    if ( $status =~ /^3/ ) {

        while ( my $line = <$socket> ) {
            chomp($line);

            last if ( $line =~ /^\.$/ );
            my @tuples = split( /\t/, $line );
            my %topichash;
            foreach my $pair (@tuples) {
                my ( $key, $value ) = split( /:/, $pair );
                $topichash{$key} = $value;
            }
            my $topicid = $topichash{topic};
            $forums{$topicid} = \%topichash;
        }
        return %forums;
    }
    else {
        $@ = "Topic listing failed with response $status";
        return;
    }
}

sub jump {
    my $self  = shift;
    my $forum = $_[0];

    my $socket = $self->{_socket};

    print $socket "TOPIC $forum\n";
    my $response = <$socket>;
    if ( $response =~ /^2/ ) {
        my $forumdata = {};

        $response =~ s/^.*?\t//;
        my @tuples = split( /\t/, $response );
        foreach my $pair (@tuples) {
            my ( $key, $value ) = split( /:/, $pair );
            if ( $key eq "admin" ) {
                my ( $id, $name, $hidden ) = split( /\//, $value );
                $value = $name;
            }
            $forumdata->{$key} = $value;
        }

        $self->{_forum}     = $forumdata->{topic};
        $self->{_lastnote}  = $forumdata->{lastnote};
        $self->{_firstnote} = $forumdata->{firstnote};

        return $forumdata;

    }
    else {
        $@ = "Jump to forum $forum died with error $response";
        return;
    }
}

sub get_first_unread {
    my $self   = shift;
    my $socket = $self->{_socket};

    print $socket "SHOW rcval\n";
    chomp( my $response = <$socket> );
    if ( $response =~ /^2.*?\t(\d+)$/ ) {
        return $1;
    }
    else {
        $@ = "SHOW rcval failed with response $response";
        return;
    }

}

sub read {
    my ( $self, %options ) = @_;
    my $socket  = $self->{_socket};
    my $message = $options{message} || $self->get_first_unread;
    unless ($message) {
        my @noteids = $self->get_forum_noteids;
        $message = $noteids[0];
    }
    my $dammit  = $options{dammit} || 0;
    if ( $message > $self->{_lastnote} ) {
        return;
    }
    else {
        my $nextmessage = $message + 1;
        if ($dammit) {
            print $socket "READ $message DAMMIT\n";
        }
        else {
            print $socket "READ $message\n";
        }
        chomp( my $response = <$socket> );
        if ( $response =~ /^3/ ) {
            my %message;
            while (1) {

                # Get header info until we hit a blank line
                chomp( my $headerline = <$socket> );
                last if ( $headerline =~ /^$/ );
                my ( $key, $value ) = split( /:\s+/, $headerline );
                $key = lc($key);
                $key = "author" if ( $key eq "from" );
                next if ( $key eq "formal-name" );
                $message{$key} = $value;
            }

            my @lines;

            while ( chomp( $response = <$socket> ) ) {
                last if ( $response =~ /^\.$/ );
                push( @lines, $response );
            }
            my $body = join( "\n", @lines );

            $message{body} = $body;

            return \%message;
        }
        else {
            $@ = "Read of $message failed with response $response";
            return;
        }
    }

}

sub get_forum_noteids {
    my @noteids;
    my $self   = shift;
    my $socket = $self->{_socket};
    unless ( defined $self->{_forum} ) {
        $@ = "Forum not defined";
        return;
    }

    print $socket "XHDR\n";
    my $result = <$socket>;
    if ( $result =~ /^3/ ) {
        while ( my $noteinfo = <$socket> ) {
            last if ( $noteinfo =~ /^\./ );
            push( @noteids, $1 ) if ( $noteinfo =~ /^noteno:(\d+)/ );
        }

        return @noteids;
    }
    else {
        $@ = "XHDR failed with response $result";
        return;
    }
}

sub get_forum_headers {
    my %xhdr;
    my $self   = shift;
    my $range  = shift || "";
    my $socket = $self->{_socket};
    return unless defined $self->{_forum};

    print $socket "XHDR ALL $range\n";
    my $result = <$socket>;
    if ( $result =~ /^3/ ) {
        while ( my $noteinfo = <$socket> ) {
            last if ( $noteinfo =~ /^\./ );
            my $notenum;
            my %tmphash;
            chomp($noteinfo);
            my @tuples = split( /\t/, $noteinfo );
            foreach my $tuple (@tuples) {
                my $key;
                my $value;
                if ( $tuple =~ /^(.*?):(.*)$/ ) {
                    $key   = $1;
                    $value = $2;
                }
                else {
                    next;
                }
                if ( $key eq "noteno" ) {
                    $notenum = $value;
                }
                elsif ( $key eq "formal-author" ) {
                    my ( undef, $author, undef ) = split( /\//, $value );
                    $tmphash{author} = $author;
                }
                else {
                    $tmphash{$key} = $value;
                }
            }
            $xhdr{$notenum} = \%tmphash;
        }
        return %xhdr;
    }
    else {
        $@ = "XHDR ALL failed with response $result";
        return;
    }
}

sub post {
    my $self    = shift;
    my $message = shift or return;
    my $socket  = $self->{_socket};
    return unless defined $self->{_forum};

    print $socket "POST\n";
    chomp( my $post_resp = <$socket> );
    if ( $post_resp !~ /^3/ ) {
        $@ = "POST command failed with response $post_resp";
        return;
    }

    print $socket "$message\n";
    print $socket ".\n";
    chomp( my $data_resp = <$socket> );
    if ( $data_resp =~ /^2/ ) {
        $data_resp =~ / .*?(\d+)/;
        return $1;
    }
    else {
        $@ = "POST data failed with response $data_resp";
        return;
    }
}

sub delete {
    my $self   = shift;
    my $postid = shift or return;
    my $socket = $self->{_socket};
    return unless defined $self->{_forum};

    print $socket "DELETE NOTE $postid\n";
    chomp( my $delete_resp = <$socket> );

    if ( $delete_resp =~ /^2/ ) {
        return 1;
    }
    else {
        $@ = "Deletion of note $postid failed with response $delete_resp";
        return;
    }
}

sub set_first_unread {
    my $self      = shift;
    my $socket    = $self->{_socket};
    my $messageid = shift or return;

    if (   ( $messageid >= $self->{_firstnote} )
        && ( $messageid <= ( $self->{_lastnote} + 1 ) ) )
    {
        print $socket "SETRC $messageid\n";
        my $response = <$socket>;
        if ( $response =~ /^2/ ) {
            return 1;
        }
        else {
            $@ = "SETRC returned bad status: $response";
            return;
        }
    }
    else {
        return;
    }
}

sub forums_with_unread {
    my $self   = shift;
    my $socket = $self->{_socket};
    my %unread;
    if ( !$self->{_loggedin} ) {
        return;
    }
    my %forums = $self->forums("todo");
    foreach my $key ( sort keys %forums ) {
        my $unread_count = $forums{$key}->{todo};
        $unread{$key} = {
            unread    => $unread_count,
            name      => $forums{$key}->{name},
            firstnote => $forums{$key}->{firstnote},
            lastnote  => $forums{$key}->{lastnote}
        };
    }

    return (%unread);
}

sub get_fi {
    my $self   = shift;
    my $socket = $self->{_socket};
    print $socket "SHOW info\n";
    my $result = <$socket>;
    if ( $result =~ /^3/ ) {
        chomp( my $fromline = <$socket> );
        my $author = $1 if ( $fromline =~ /From: (.*)/ );
        chomp( my $dateline = <$socket> );
        my $date = $1 if ( $dateline =~ /Date: (.*)/ );
        my $blankline = <$socket>;

        my @lines;

        while ( chomp( my $line = <$socket> ) ) {
            last if ( $line =~ /^\.$/ );
            push( @lines, $line );
        }
        my $body = join( "\n", @lines );
        my $fi = { fi_author => $author, last_updated => $date, body => $body };
        return $fi;
    }
    else {
        $@ = "SHOW INFO failed with response $result";
        return;
    }
}

sub can_post {
    my $self   = shift;
    my $socket = $self->{_socket};
    return unless defined $self->{_forum};

    print $socket "OKAY POST\n";
    chomp( my $result = <$socket> );
    if ( $result =~ /^2/ ) {
        return 1;
    }
    else {
        $@ = "OKAY POST failed with the following response: $result";
        return;
    }
}

sub xmsg_add {
    my $self   = shift;
    my $socket = $self->{_socket};

}

sub logout {
    my $socket = $_[0]->{_socket};
    print $socket "QUIT\n";
    $socket->close() or return;
}

1;

__END__