popfile 1.1.3+dfsg-0ubuntu1 / usr / share / popfile / POPFile / Module.pm

#----------------------------------------------------------------------------
#
# This is POPFile's top level Module object.
#
# Copyright (c) 2001-2011 John Graham-Cumming
#
#   This file is part of POPFile
#
#   POPFile is free software; you can redistribute it and/or modify it
#   under the terms of version 2 of the GNU General Public License as
#   published by the Free Software Foundation.
#
#   POPFile is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with POPFile; if not, write to the Free Software
#   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
#
#----------------------------------------------------------------------------

package POPFile::Module;

use strict;
use IO::Select;

# ----------------------------------------------------------------------------
#
# This module implements the base class for all POPFile Loadable
# Modules and contains collection of methods that are common to all
# POPFile modules and only selected ones need be overriden by
# subclasses
#
# POPFile is constructed from a collection of classes which all have
# special PUBLIC interface functions:
#
# initialize() - called after the class is created to set default
# values for internal variables and global configuration information
#
# start() - called once all configuration has been read and POPFile is
# ready to start operating
#
# stop()       - called when POPFile is shutting down
#
# service() - called by the main POPFile process to allow a submodule
# to do its own work (this is optional for modules that do not need to
# perform any service)
#
# prefork() - called when a module has requested a fork, but before
# the fork happens
#
# forked() - called when a module has forked the process.  This is
# called within the child process and should be used to clean up
#
# postfork() - called in the parent process to tell it that the fork
# has occurred.  This is like forked but in the parent.
#
# childexit() - called in a child process when the child is about
# to exit.
#
# reaper() - called when a process has terminated to give a module a
# chance to do whatever clean up is needed
#
# name() - returns a simple name for the module by which other modules
# can get access through the %components hash.  The name returned here
# will be the name used as the key for this module in %components
#
# deliver()    - called by the message queue to deliver a message
#
# The following methods are PROTECTED and should be accessed by sub classes:
#
# log_() - sends a string to the logger
#
# config_() - gets or sets a configuration parameter for this module
#
# mq_post_() - post a message to the central message queue
#
# mq_register_() - register for messages from the message queue
#
# slurp_() - Reads a line up to CR, CRLF or LF
#
# register_configuration_item_() - register a UI configuration item
#
# A note on the naming
#
# A method or variable that ends with an underscore is PROTECTED and
# should not be accessed from outside the class (or subclass; in C++
# its protected), to access a PROTECTED variable you will find an
# equivalent getter/setter method with no underscore.
#
# Truly PRIVATE variables are indicated by a double underscore at the
# end of the name and should not be accessed outside the class without
# going through a getter/setter and may not be directly accessed by a
# subclass.
#
# For example
#
# $c->foo__() is a private method $c->{foo__} is a private variable
# $c->foo_() is a protected method $c->{foo_} is a protected variable
# $c->foo() is a public method that modifies $c->{foo_} it always
# returns the current value of the variable it is referencing and if
# passed a value sets that corresponding variable
#
# ----------------------------------------------------------------------------

# This variable is CLASS wide, not OBJECT wide and is used as
# temporary storage for the slurp_ methods below.  It needs to be
# class wide because different objects may call slurp on the same
# handle as the handle gets passed from object to object.

my %slurp_data__;

#----------------------------------------------------------------------------
# new
#
#   Class new() function, all real work gets done by initialize and
#   the things set up here are more for documentation purposes than
#   anything so that you know that they exists
#
#----------------------------------------------------------------------------
sub new
{
    my $type = shift;
    my $self;

    # A reference to the POPFile::Configuration module, every module is
    # able to get configuration information through this, note that it
    # is valid when initialize is called, however, the configuration is not
    # read from disk until after initialize has been called

    $self->{configuration__} = 0; # PRIVATE

    # A reference to the POPFile::Logger module

    $self->{logger__}        = 0; # PRIVATE

    # A reference to the POPFile::MQ module

    $self->{mq__}            = 0;

    # The name of this module

    $self->{name__}          = ''; # PRIVATE

    # Used to tell any loops to terminate

    $self->{alive_}          = 1;

    # This is a reference to the pipeready() function in popfile.pl
    # that it used to determine if a pipe is ready for reading in a
    # cross platform way

    $self->{pipeready_}      = 0;

    # This is a reference to a function (forker) in popfile.pl that
    # performs a fork and informs modules that a fork has occurred

    $self->{forker_}         = 0;

    return bless $self, $type;
}

# ----------------------------------------------------------------------------
#
# initialize
#
# Called to initialize the module, the main task that this function
# should perform is setting up the default values of the configuration
# options for this object.  This is done through the configuration_
# hash value that will point the configuration module.
#
# Note that the configuration is not loaded from disk until after
# every module's initialize has been called, so do not use any of
# these values until start() is called as they may change
#
# The method should return 1 to indicate that it initialized
# correctly, if it returns 0 then POPFile will abort loading
# immediately
#
# ----------------------------------------------------------------------------
sub initialize
{
    my ( $self ) = @_;

    return 1;
}

# ----------------------------------------------------------------------------
#
# start
#
# Called when all configuration information has been loaded from disk.
#
# The method should return 1 to indicate that it started correctly, if
# it returns 0 then POPFile will abort loading immediately, returns 2
# if everything OK but this module does not want to continue to be
# used.
#
# ----------------------------------------------------------------------------
sub start
{
    my ( $self ) = @_;

    return 1;
}

# ----------------------------------------------------------------------------
#
# stop
#
# Called when POPFile is closing down, this is the last method that
# will get called before the object is destroyed.  There is no return
# value from stop().
#
# ----------------------------------------------------------------------------
sub stop
{
    my ( $self ) = @_;
}

# ----------------------------------------------------------------------------
#
# reaper
#
# Called when a child process terminates somewhere in POPFile.  The
# object should check to see if it was one of its children and do any
# necessary processing by calling waitpid() on any child handles it
# has
#
# There is no return value from this method
#
# ----------------------------------------------------------------------------
sub reaper
{
    my ( $self ) = @_;
}

# ----------------------------------------------------------------------------
#
# service
#
# service() is a called periodically to give the module a chance to do
# housekeeping work.
#
# If any problem occurs that requires POPFile to shutdown service()
# should return 0 and the top level process will gracefully terminate
# POPFile including calling all stop() methods.  In normal operation
# return 1.
#
# ----------------------------------------------------------------------------
sub service
{
    my ( $self ) = @_;

    return 1;
}

# ----------------------------------------------------------------------------
#
# prefork
#
# This is called when some module is about to fork POPFile
#
# There is no return value from this method
#
# ----------------------------------------------------------------------------
sub prefork
{
    my ( $self ) = @_;
}

# ----------------------------------------------------------------------------
#
# forked
#
# This is called when some module forks POPFile and is within the
# context of the child process so that this module can close any
# duplicated file handles that are not needed.
#
# $writer The writing end of a pipe that can be used to send up from
#         the child
#
# There is no return value from this method
#
# ----------------------------------------------------------------------------
sub forked
{
    my ( $self, $writer ) = @_;
}

# ----------------------------------------------------------------------------
#
# postfork
#
# This is called when some module has just forked POPFile.  It is
# called in the parent process.
#
# $pid The process ID of the new child process $reader The reading end
#      of a pipe that can be used to read messages from the child
#
# There is no return value from this method
#
# ----------------------------------------------------------------------------
sub postfork
{
    my ( $self, $pid, $reader ) = @_;
}

# ----------------------------------------------------------------------------
#
# childexit
#
# Called in a child process when the child is about to exit
#
# There is no return value from this method
#
# ----------------------------------------------------------------------------
sub childexit
{
    my ( $self ) = @_;
}

# ----------------------------------------------------------------------------
#
# deliver
#
# Called by the message queue to deliver a message
#
# There is no return value from this method
#
# ----------------------------------------------------------------------------
sub deliver
{
    my ( $self, $type, @message ) = @_;
}

# ----------------------------------------------------------------------------
#
# log_
#
# Called by a subclass to send a message to the logger, the logged
# message will be prefixed by the name of the module in use
#
# $level             The log level (see POPFile::Logger for details)
# $message           The message to log
#
# There is no return value from this method
#
# ----------------------------------------------------------------------------
sub log_
{
    my ( $self, $level, $message ) = @_;

    my ( $package, $file, $line ) = caller;
    $self->{logger__}->debug( $level, "$self->{name__}: $line: $message" );
}

# ----------------------------------------------------------------------------
#
# config_
#
# Called by a subclass to get or set a configuration parameter
#
# $name              The name of the parameter (e.g. 'port')
# $value             (optional) The value to set
#
# If called with just a $name then config_() will return the current value
# of the configuration parameter.
#
# ----------------------------------------------------------------------------
sub config_
{
    my ( $self, $name, $value ) = @_;

    return $self->module_config_( $self->{name__}, $name, $value );
}

# ----------------------------------------------------------------------------
#
# mq_post_
#
# Called by a subclass to post a message to the message queue
#
# $type              Type of message to send
# @message           Message to send
#
# ----------------------------------------------------------------------------
sub mq_post_
{
    my ( $self, $type, @message ) = @_;

    return $self->{mq__}->post( $type, @message );
}

# ----------------------------------------------------------------------------
#
# mq_register_
#
# Called by a subclass to register with the message queue for messages
#
# $type              Type of message to send
# $object            Callback object
#
# ----------------------------------------------------------------------------
sub mq_register_
{
    my ( $self, $type, $object ) = @_;

    return $self->{mq__}->register( $type, $object );
}

# ----------------------------------------------------------------------------
#
# global_config_
#
# Called by a subclass to get or set a global (i.e. not module
# specific) configuration parameter
#
# $name              The name of the parameter (e.g. 'port')
# $value             (optional) The value to set
#
# If called with just a $name then global_config_() will return the
# current value of the configuration parameter.
#
# ----------------------------------------------------------------------------
sub global_config_
{
    my ( $self, $name, $value ) = @_;

    return $self->module_config_( 'GLOBAL', $name, $value );
}

# ----------------------------------------------------------------------------
#
# module_config_
#
# Called by a subclass to get or set a module specific configuration parameter
#
# $module The name of the module that owns the parameter (e.g. 'pop3')
# $name   The name of the parameter (e.g. 'port') $value (optional) The
#         value to set
#
# If called with just a $module and $name then module_config_() will
# return the current value of the configuration parameter.
#
# ----------------------------------------------------------------------------
sub module_config_
{
    my ( $self, $module, $name, $value ) = @_;

    return $self->{configuration__}->parameter( $module . "_" . $name, $value );
}

# ----------------------------------------------------------------------------
#
# register_configuration_item_
#
# Called by a subclass to register a UI element
#
# $type, $name, $templ, $object
#     See register_configuration_item__ in UI::HTML
#
# ----------------------------------------------------------------------------
sub register_configuration_item_
{
    my ( $self, $type, $name, $templ, $object ) = @_;

    return $self->mq_post_( 'UIREG', $type, $name, $templ, $object );
}

# ----------------------------------------------------------------------------
#
# get_user_path_, get_root_path_
#
# Wrappers for POPFile::Configuration get_user_path and get_root_path
#
# $path              The path to modify
# $sandbox           Set to 1 if this path must be sandboxed (i.e. absolute
#                    paths and paths containing .. are not accepted).
#
# ----------------------------------------------------------------------------
sub get_user_path_
{
    my ( $self, $path, $sandbox ) = @_;

    return $self->{configuration__}->get_user_path( $path, $sandbox );
}

sub get_root_path_
{
    my ( $self, $path, $sandbox ) = @_;

    return $self->{configuration__}->get_root_path( $path, $sandbox );
}

# ----------------------------------------------------------------------------
#
# flush_slurp_data__
#
# Helper function for slurp_ that returns an empty string if the slurp
# buffer doesn't contain a complete line, or returns a complete line.
#
# $handle            Handle to read from, which should be in binmode
#
# ----------------------------------------------------------------------------
sub flush_slurp_data__
{
    my ( $self, $handle ) = @_;

    # The acceptable line endings are CR, CRLF or LF.  So we look for
    # them using these regexps.

    # Look for LF

    if ( $slurp_data__{"$handle"}{data} =~ s/^([^\015\012]*\012)// ) {
        return $1;
    }

    # Look for CRLF

    if ( $slurp_data__{"$handle"}{data} =~ s/^([^\015\012]*\015\012)// ) {
        return $1;
    }

    # Look for CR, here we have to be careful because of the fact that
    # the current total buffer could be ending with CR and there could
    # actually be an LF to read, so we check for that situation if we
    # find CR

    if ( $slurp_data__{"$handle"}{data} =~ s/^([^\015\012]*\015)// ) {
        my $cr = $1;

        # If we have removed everything from the buffer then see if
        # there's another character available to read, if there is
        # then get it and check to see if it is LF (in which case this
        # is a line ending CRLF), otherwise just save it

        if ( $slurp_data__{"$handle"}{data} eq '' ) {

            if ( $self->can_read__( $handle )) {
                my $c;
                my $retcode = sysread( $handle, $c, 1 );
                if ( $retcode == 1 ) {
                    if ( $c eq "\012" ) {
                        $cr .= $c;
                    } else {
                        $slurp_data__{"$handle"}{data} = $c;
                    }
                }
            }
        }

        return $cr;
    }

    return '';
}

# ----------------------------------------------------------------------------
#
# slurp_data_size__
#
# $handle          A connection handle previously used with slurp_
#
# Returns the length of data currently buffered for the passed in handle
#
# ----------------------------------------------------------------------------

sub slurp_data_size__
{
    my ( $self, $handle ) = @_;

    return defined($slurp_data__{"$handle"}{data})?length($slurp_data__{"$handle"}{data}):0;
}

# ----------------------------------------------------------------------------
#
# slurp_buffer_
#
# $handle                     Handle to read from, which should be in binmode
# $length                     The amount of data to read
#
# Reads up to $length bytes from $handle and returns it, if there is nothing
# to return because the buffer is empty and the handle is at eof then this
# will return undef
#
# ----------------------------------------------------------------------------

sub slurp_buffer_
{
    my ( $self, $handle, $length ) = @_;

    while ( $self->slurp_data_size__( $handle ) < $length ) {
        my $c;
        if ( $self->can_read__( $handle, 0.01 ) && ( sysread( $handle, $c, $length ) > 0 ) ) {
            $slurp_data__{"$handle"}{data} .= $c;
        } else {
            last;
        }
    }

    my $result = '';

    if ( $self->slurp_data_size__( $handle ) < $length ) {
        $result = $slurp_data__{"$handle"}{data};
        $slurp_data__{"$handle"}{data} = '';
    } else {
        $result = substr( $slurp_data__{"$handle"}{data}, 0, $length );
        $slurp_data__{"$handle"}{data} =                       # PROFILE BLOCK START
            substr( $slurp_data__{"$handle"}{data}, $length ); # PROFILE BLOCK STOP
    }

    return ($result ne '')?$result:undef;
}

# ----------------------------------------------------------------------------
#
# slurp_
#
# A replacement for Perl's <> operator on a handle that reads a line
# until CR, CRLF or LF is encountered.  Returns the line if read (with
# the CRs and LFs), or undef if at the EOF, blocks waiting for
# something to read.
#
# IMPORTANT NOTE: If you don't read to the end of the stream using
# slurp_ then there may be a small memory leak caused by slurp_'s
# buffering of data in the Module's hash.  To flush it make a call to
# slurp_ when you know that the handle is at the end of the stream, or
# call done_slurp_ on the handle.
#
# $handle            Handle to read from, which should be in binmode
#
# ----------------------------------------------------------------------------
sub slurp_
{
    my ( $self, $handle, $timeout ) = @_;

    $timeout = $self->global_config_( 'timeout' ) if ( !defined( $timeout ) );

    if ( !defined( $slurp_data__{"$handle"}{data} ) ) {
        $slurp_data__{"$handle"}{select} = new IO::Select( $handle );
        $slurp_data__{"$handle"}{data}   = '';
    }

    my $result = $self->flush_slurp_data__( $handle );

    if ( $result ne '' ) {
        return $result;
    }

    my $c;

    if ( $self->can_read__( $handle, $timeout ) ) {
        while ( sysread( $handle, $c, 160 ) > 0 ) {
            $slurp_data__{"$handle"}{data} .= $c;

            $self->log_( 2, "Read slurp data $c" );

            $result = $self->flush_slurp_data__( $handle );

            if ( $result ne '' ) {
                return $result;
            }
        }
    } else {

        # Server has not respond. Close the connection and return

        $self->done_slurp_( $handle );
        close $handle;
        return undef;
    }

    # If we get here with something in line then the file ends without any
    # CRLF so return the line, otherwise we are reading at the end of the
    # stream/file so return undef

    my $remaining = $slurp_data__{"$handle"}{data};
    $self->done_slurp_( $handle );

    if ( $remaining eq '' ) {
        return undef;
    } else {
        return $remaining;
    }
}

# ----------------------------------------------------------------------------
#
# done_slurp_
#
# Call this when have finished calling slurp_ on a handle and need to
# clean up temporary buffer space used by slurp_
#
# ----------------------------------------------------------------------------

sub done_slurp_
{
    my ( $self, $handle ) = @_;

    delete $slurp_data__{"$handle"}{select};
    delete $slurp_data__{"$handle"}{data};
    delete $slurp_data__{"$handle"};
}

# ----------------------------------------------------------------------------
#
# flush_extra_ - Read extra data from the mail server and send to
# client, this is to handle POP servers that just send data when they
# shouldn't.  I've seen one that sends debug messages!
#
# Returns the extra data flushed
#
# $mail        The handle of the real mail server
# $client      The mail client talking to us
# $discard     If 1 then the extra output is discarded
#
# ----------------------------------------------------------------------------
sub flush_extra_
{
    my ( $self, $mail, $client, $discard ) = @_;

    $discard = 0 if ( !defined( $discard ) );

    # If slurp has any data, we want it

    if ( $self->slurp_data_size__($mail) ) {

        print $client $slurp_data__{"$mail"}{data} if ( $discard != 1 );
        $slurp_data__{"$mail"}{data} = '';
    }

    # Do we always attempt to read?

    my $always_read = 0;
    my $selector;

    if (($^O eq 'MSWin32') && !($mail =~ /socket/i) ) {

        # select only works reliably on IO::Sockets in Win32, so we
        # always read files on MSWin32 (sysread returns 0 for eof)

        $always_read = 1; # PROFILE PLATFORM START MSWin32
                          # PROFILE PLATFORM STOP
    } else {

        # in all other cases, a selector is used to decide whether to read

        $selector    = new IO::Select( $mail );
        $always_read = 0;
    }

    my $ready;

    my $buf        = '';
    my $full_buf   = '';
    my $max_length = 8192;
    my $n;

    while ( $always_read || defined( $selector->can_read(0.01) ) ) {
        $n = sysread( $mail, $buf, $max_length, length $buf );

        if ( $n > 0 ) {
            print $client $buf if ( $discard != 1 );
            $full_buf .= $buf;
        } else {
            if ($n == 0) {
                last;
            }
        }
    }

   return $full_buf;
}

# ----------------------------------------------------------------------------
#
# can_read__ - Check whether we can read from the specified handle
#
# Returns true if we can read from the handle
#
# $handle      A connection handle
# $timeout     A timeout period (in seconds)
#
# ----------------------------------------------------------------------------
sub can_read__
{
    my ( $self, $handle, $timeout ) = @_;
    $timeout = $self->global_config_( 'timeout' ) if ( !defined($timeout) );

    # This unpleasant boolean is to handle the case where we
    # are slurping a non-socket stream under Win32

    my $can_read = ( ( $handle !~ /socket/i ) && ( $^O eq 'MSWin32' ) );

    if ( !$can_read ) {
        if ( $handle =~ /ssl/i ) {

            # If using SSL, check internal buffer of OpenSSL first.

            $can_read = ( $handle->pending() > 0 );
        }
        if ( !$can_read ) {
            if ( defined( $slurp_data__{"$handle"}{select} ) ) {
                $can_read = defined( $slurp_data__{"$handle"}{select}->can_read( $timeout ) );
            } else {
                my $selector    = new IO::Select( $handle );
                $can_read = defined( $selector->can_read( $timeout ) );
            }
        }
    }

    return $can_read;
}

# GETTER/SETTER methods.  Note that I do not expect documentation of
# these unless they are non-trivial since the documentation would be a
# waste of space
#
# The only thing to note is the idiom used, stick to that and there's
# no need to document these
#
#   sub foo
#   {
#       my ( $self, $value ) = @_;
#
#       if ( defined( $value ) ) {
#           $self->{foo_} = $value;
#       }
#
#       return $self->{foo_};
#   }
#
# This method access the foo_ variable for reading or writing,
# $c->foo() read foo_ and $c->foo( 'foo' ) writes foo_

sub mq
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{mq__} = $value;
    }

    return $self->{mq__};
}

sub configuration
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{configuration__} = $value;
    }

    return $self->{configuration__};
}

sub forker
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{forker_} = $value;
    }

    return $self->{forker_};
}

sub logger
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{logger__} = $value;
    }

    return $self->{logger__};
}

sub setchildexit
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{childexit_} = $value;
    }

    return $self->{childexit_};
}

sub pipeready
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{pipeready_} = $value;
    }

    return $self->{pipeready_};
}

sub alive
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{alive_} = $value;
    }

    return $self->{alive_};
}

sub name
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{name__} = $value;
    }

    return $self->{name__};
}

sub version
{
    my ( $self, $value ) = @_;

    if ( defined( $value ) ) {
        $self->{version_} = $value;
    }

    return $self->{version_};
}

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

    return $self->{logger__}->last_ten();
}

1;