File Coverage

blib/lib/GMail/Checker.pm

Criterion	Covered	Total	%
statement	31	283	10.9
branch	3	116	2.5
condition	2	9	22.2
subroutine	7	21	33.3
pod	10	16	62.5
total	53	445	11.9

package GMail::Checker;

# Perl interface for a gmail wrapper
# Allows you to check new mails, retrieving new mails and information about them

# $Id: Checker.pm,v 1.04 2004/12/13 22:52:17 sacred Exp $

use strict;
use IO::Socket::SSL;
use Carp;
use vars qw($VERSION);

$VERSION = 1.04;

sub version { sprintf("%f", $VERSION); }

sub new {
    my $self = {};
    my $proto = shift;
    my %params = @_;
    $self->{SOCK} = undef;
    $self->{NBMSG} = 0;
    $self->{USERNAME} = '';
    $self->{PASSWORD} = '';
    my $class = ref($proto) || $proto;
    bless($self,$class);
    $self->login($params{"USERNAME"}, $params{"PASSWORD"}) if ((exists $params{"USERNAME"}) and (exists $params{"PASSWORD"}));
    return $self;
}

sub DESTROY {
    my $self = shift;
    if (defined $self->{SOCK}) { $self->{SOCK}->close(); }
}

sub getsize { # Formatting the mail[box] size in a pretty manner
    my $self = shift;
    my $size = shift;
    $size /= 1024;
    my $unit = "Kbytes";
    ($size, $unit) = ($size/1024, "Mbytes") if (($size / 1024) > 1) ;
    return ($size, $unit);
}

sub login {
    my $self = shift;
    my ($login, $passwd) = @_;
    my $not = new IO::Socket::SSL "pop.gmail.com:995" or die IO::Socket::SSL->errstr();
    $self->{SOCK} = $not;
    my $line = <$not>; # Reading the welcome message
    print $not "USER $login\r\n";
    $line = <$not>;
    if ($line !~ /^\+OK/) { print "Wrong username, please check your settings.\n"; $self->close(); } # We are not allowing USER on transaction state.
    print $not "PASS $passwd\r\n";
    $line = <$not>;
    if ($line !~ /^\+OK/) { print "Wrong password, please check your settings.\n"; $self->close(); } # Same as above for PASS.
    $self->{USERNAME} = $login;
    $self->{PASSWORD} = $passwd;
    return 1;
}

sub get_msg_nb_size {
    my $self = shift;
    if (defined $self->{SOCK}) {
	my $gsocket = $self->{SOCK};
	print $gsocket "STAT\r\n";
	my $gans = <$gsocket>;
	unless ($gans !~ /^\+OK\s(\d+)\s(\d+)(\s.*)?\r\n/) {
	    return ($1,$2); # Sending the number of messages and the size of the mailbox
	}
    } else { croak "Operation failed, connection to server is not established.\n"; }
}

sub get_pretty_nb_messages {
    my $self = shift;
    my %params = @_;
    $params{"ALERT"} = "TOTAL_MSG" unless exists $params{"ALERT"}; # Making sure we have an alert type.
    if (defined $self->{SOCK}) {
	my $gsocket = $self->{SOCK};
	print $gsocket "STAT\r\n";
	my $gans = <$gsocket>;
	unless ($gans !~ /^\+OK\s(\d+)\s(\d+)(\s.*)?\r\n/) {
	    if ($params{"ALERT"} eq "NEW_MSG_ONLY") {
		if ($1 > $self->{NBMSG}) {
		    return sprintf "You have %d new messages.\n", $1 - $self->{NBMSG};
		}
	    }
	    $self->{NBMSG} = $1;
	    return sprintf "You have $1 messages in your inbox (size %0.2f %s)\n", $self->getsize($2) unless $params{"ALERT"} eq "NEW_MSG_ONLY";
	}
    } else { croak "Operation failed, connection to server is not established.\n"; }
}

sub get_msg_size {
    my $self = shift;
    my %params = @_;
    if (defined $self->{SOCK}) {
	my (@msg_size, $gans);
	my $gsocket = $self->{SOCK};
	if (exists $params{"MSG"}) {
	    print $gsocket "LIST " . $params{"MSG"} . "\r\n";
	    $gans = <$gsocket>;
	    if ($gans =~ /^\+OK\s(\d+)\s(\d+)/) {
		($msg_size[0]->{nb}, $msg_size[0]->{size}) = ($1, $2);
		return @msg_size;
	    } else { print "No such message number.\r\n"; }
	} else {
	    print $gsocket "LIST\r\n";
	    my $i = 0;
	    for ($gans = <$gsocket>; $gans ne ".\r\n"; $gans = <$gsocket>) {
		if ($gans =~ /^(\d+)\s(\d+)/) {
		    ($msg_size[$i]->{nb}, $msg_size[$i]->{size}) = ($1, $2);
		    $i++;
		}
	    }
	    ($msg_size[0]->{nb}, $msg_size[0]->{size}) = (-1,-1) if $i == 0; # Mailbox is empty
	    return @msg_size;
	}
    }
}

sub parse_plain_msg {
    my $self = shift;
    my ($gsocket, $msgl) = ($self->{SOCK}, "");
    for (my $gans = <$gsocket>; $gans ne ".\r\n"; $gans = <$gsocket>) {
	$msgl .= $gans;
    }
    return $msgl;
}

sub msg_to_file {
    my $self = shift;
    my $ind = shift;
    my $gsocket = $self->{SOCK};
    print $gsocket "RETR $ind\r\n";
    my $gans = "";
    my @uidl = $self->get_uidl(MSG => $ind);
    open(MAILFILE, ">" .  $uidl[0]->{hash});
    while ($gans ne ".\r\n") {
	$gans = <$gsocket>;
	print MAILFILE $gans;
    }
    close(MAILFILE);
}

sub parse_multipart_msg {
    my $self = shift;
    my ($gsocket, $msgl, $gans) = ($self->{SOCK}, "", "");
    my %msgs = @_;
    my @attachments = undef;
    my ($content, $opt, $opttype, $encoding, $filename) =  (undef, undef, undef, undef, undef);
    my $boundary = $msgs{opt};
    while ($gans !~ /^--$boundary/) { $gans = <$gsocket>; }

    # Retrieving the message body [inline text].
    while ($gans ne "\r\n") {
	$gans = <$gsocket>;
	if ($gans =~ /^Content-Type: ([a-z0-9\/-]+);\s?(?:([a-z0-9-]+)=\"?([a-z0-9._=-]+)\"?)?\r\n/i) {
	    $content = $1;
	    if (!defined $2) {
		$gans = <$gsocket>;
		$gans =~ /\s+([a-z0-9-]+)=\"?([a-z0-9._=-]+)\"?\r\n/i;
		$opt = $2;
		$opttype = $1;
	    } else { $opt = $3; $opttype = $2; } # Content options (eg. name, charset)
	}
	if ($gans =~ /^Content-Transfer-Encoding: (7bit|8bit|binary|base64|quote-printable|ietf-token|x-token)\r\n/i) {
	    $encoding = $1;
	}
    }
    do {
	$gans = <$gsocket>;
	$msgs{body} .= $gans unless $gans =~ /^--$boundary/;
    } while (($gans ne ".\r\n") && ($gans !~ /^--$boundary/i));
    $msgs{contentmsg} = $content;
    $msgs{optmsg} = $opt;
    $msgs{opttypemsg} = $opttype;
    $msgs{encoding} = $encoding;

    # Retrieving attachements.

    for (my $i = -1; $gans ne ".\r\n";) {
	if ($gans =~ /^--$boundary/) {
	    $i++;
	    ($content, $opt, $opttype, $encoding, $filename) =  ("","","","","");
	    $gans = <$gsocket>;
	    while ($gans !~ /^(?:--$boundary|\.\r\n)/) {
		if ($gans =~ /^Content-Type: ([a-z0-9\/-]+);\s?(?:([a-z0-9-]+)=\"?([a-z0-9._=-]+)\"?)?\r\n/i) {
		    $content = $1;
		    if (!defined $2) {
			$gans = <$gsocket>;
			$gans =~ /\s+([a-z0-9-]+)=\"?([a-z0-9._=-]+)\"?\r\n/i;
			$opt = $2;
			$opttype = $1;
		    } else { $opt = $3; $opttype = $2; } # Content options (eg. name, charset)
		}
		if ($gans =~ /^Content-Transfer-Encoding: (7bit|8bit|binary|base64|quote-printable|ietf-token|x-token)\r\n/i) {
		    $encoding = $1;
		}
		if ($gans =~ /^Content-Disposition: ([a-z]+);(?:\s+filename=\"?(\S+)\"?)?/) {
		    if ($1 eq "attachment") {
			if (!defined $2) {
			    $gans = <$gsocket>;
			    ($attachments[$i]->{filename}) = $gans =~ /\s+filename=\"?(\S+)\"?/;
			} else {$attachments[$i]->{filename} = $3; }
			while ($gans ne "\r\n") {
			    $gans = <$gsocket>;
			    if ($gans =~ /^\s+$/) { next; }
			    $attachments[$i]->{body} .= $gans;
			}
			$attachments[$i]->{content} = $content;
			$attachments[$i]->{opt} = $opt;
			$attachments[$i]->{opttype} = $opttype;
			$attachments[$i]->{encoding} = $encoding;
			$gans = <$gsocket>;
			last;
		    }
		}
		$gans = <$gsocket>;
	    }
	}
	if ($gans !~ /^(--$boundary|\.\r\n)/i) { $gans = <$gsocket>;}
    }
    if (@attachments != 0) { $msgs{attachment} = @attachments; }
    return %msgs;
}

sub parse_msg {
    my $self = shift;
    my $ind = shift;
    my %msgs;
    my $gsocket = $self->{SOCK};
    print $gsocket "RETR $ind\r\n";
    my ($msgl, $msgtype) = ("", 0);
    my $gans = <$gsocket>;
    if ($gans =~ /^\+OK\s/) {
	do { # Getting the message headers
	    $gans = <$gsocket>;
	    $msgl .= $gans  if $gans =~ /^([A-Z][a-zA-Z0-9-]+:\s+|\t)/;
	    if ($gans =~ /^Content-Type: ([a-z0-9\/-]+);\s?(?:([a-z0-9-]+)=\"?([a-z0-9._=-]+)\"?)?\r\n/i) {
		$msgs{content} = $1;
		if ($msgs{content} =~ /^multipart\/mixed/i) { $msgtype = 1; } # Mail content
		if (!defined $2) {
		    $msgl .= $gans = <$gsocket>;
		    $gans =~ /\s+([a-z0-9-]+)=\"?([a-z0-9._=-]+)\"?\r\n/i;
		    $msgs{opt} = $2;
		    $msgs{opttype} = $1;
		} else { $msgs{opt} = $3; $msgs{opttype} = $2; } # Content options (eg. name, charset)
	    }
	    # We need to know the encoding type
	    if ($gans =~ /^Content-Type-Encoding: (7bit|8bit|binary|base64|quote-printable|ietf-token|x-token)\r\n/i) { $msgs{encoding} = $1; }
	} while ($gans ne "\r\n");
	$msgs{headers} = $msgl;
	$msgl = "";
	if (!$msgtype) { $msgs{body} = $self->parse_plain_msg(); } else { %msgs = $self->parse_multipart_msg(%msgs); }
	return %msgs;
    } else { print "No such message number (" .  $ind  .").\r\n"; }
}

sub get_msg {
    my $self = shift;
    my %params = @_;
    if (defined $self->{SOCK}) {
	my (@msgs, $gans);
	my $gsocket = $self->{SOCK};
	if (exists $params{"MSG"}) {
	    my %tmp = $self->parse_msg($params{"MSG"});
	    push(@msgs, \%tmp);
	    print $gsocket "DELE " . $params{"MSG"} . "\r\n" if exists $params{"DELETE"};
	} else {
	    my $total = shift(@{ $self->get_msg_nb_size() } );
	    for (my $ind = 1; $ind < $total; $ind++) {
		my %tmp = $self->parse_msg($ind);
		push(@msgs, \%tmp);
		print $gsocket "DELE $ind\r\n" if exists $params{"DELETE"};
	    }
	}
	return @msgs;
    }
}

sub get_msg_headers {
    my $self = shift;
    my %params = @_;
    $params{"HEADERS"} = "MINIMAL" unless exists $params{"HEADERS"}; # Making sure we have headers type for retrieval.
    my $headregx = ($params{"HEADERS"} eq "FULL") ? '^([A-Z][a-zA-Z0-9-]+:\s+|\t)' : '^(From|Subject|Date):\s+'; # Headers regexp
    my @messages = [];
    if (defined $self->{SOCK}) {
	my $gsocket = $self->{SOCK};
	my ($lastmsg, $gans) = (undef, undef);
	if (!exists $params{"MSG"}) {  # By default we get the last message's headers.
	    print $gsocket "STAT\r\n";
	    $gans = <$gsocket>;
	    if ($gans =~ /^\+OK\s(\d+)\s\d+(\s.*)?\r\n/) {
		$lastmsg = $1;
	    }
	} else { # Did we specify a message for which we want headers ?
	    $lastmsg = $params{"MSG"};
	}
	print $gsocket "TOP $lastmsg 1\r\n";
	$gans = <$gsocket>;
	if ($gans =~ /^\+OK/) {
	    do {
		$gans = <$gsocket>;
		push(@messages, $gans)  if $gans =~ /$headregx/;
	    } while ($gans ne "\r\n");

	} else { print "No such message number.\r\n"; } # Duh! We received an -ERR
	return @messages;
    } else { croak "Operation failed, socket is not open.\n"; }
}

sub get_uidl {
      my $self = shift;
      my %params = @_;
   if (defined $self->{SOCK}) {
	my (@uidls, $gans);
	my $gsocket = $self->{SOCK};
	if (exists $params{"MSG"}) {
	    print $gsocket "UIDL " . $params{"MSG"} . "\r\n";
	    $gans = <$gsocket>;
	    if ($gans =~ /^\+OK\s\d+\s<([\x21-\x7E]+)>\r\n/) { return $1; } else {  print "No such message number (" .  $params{"MSG"}  .").\r\n"; return -1;}
	} else {
	    print $gsocket "UIDL\r\n";
	    my $i = 0;
	    for ($gans = <$gsocket>; $gans ne ".\r\n"; $gans = <$gsocket>) {
		if ($gans =~ /^(\d+)\s<([\x21-\x7E]+)>\r\n/) {
		    ($uidls[$i]->{nb}, $uidls[$i]->{hash}) = ($1, $2);
		    $i++;
		}
	    }
	    ($uidls[0]->{nb}, $uidls[0]->{hash}) = (-1,-1) if $i == 0;
	    return @uidls;
	}
    } else { croak "Operation failed, socket is not open.\n"; }
}

sub rset {
    my $self = shift;
    if (defined $self->{SOCK}) {
	my $gsocket = $self->{SOCK};
	print $gsocket "RSET\r\n";
	my $gans = <$gsocket>;
	return $gans;
    } else { croak "Operation failed, socket is not open.\n"; }
}

sub close {
    my $self = shift;
    if (defined $self->{SOCK}) {
	my $gsocket = $self->{SOCK};
	print $gsocket "QUIT\r\n"; # Sending a proper quit to the server so it can make an UPDATE in case DELE requests were sent.
	$gsocket->close(SSL_ctx_free => 1); # Freeing the connection context
	$self->{SOCK} = undef;
	return 1;
    } else { croak "Operation failed, socket is not open.\n"; }
}


__END__