Perlbug::Base - Module for bringing together Config, Log, Do(wrapper functions), Database, all Objects etc.

	my $o_base = Perlbug::Base->new;

	print "System maintainer contact: ".$o_base->system('maintainer');

	print "Total bugs: ".$o_base->object('bug')->ids;

	my $o_user = $o_base->object('user')->read('richard');

	print 'User('.$o_user->attr('name').') data: '.$o_user->format('l');

# Perlbug base class 
# (C) 1999 Richard Foley RFI perlbug@rfi.net
# $Id: Base.pm,v 1.97 2002/02/01 08:36:45 richardf Exp $
# 
# TODO
# see scan
# 

package Perlbug::Base;
use strict; 
use vars qw($AUTOLOAD @ISA $VERSION); 
$VERSION = do { my @r = (q$Revision: 1.97 $ =~ /\d+/go); sprintf "%d."."%02d" x $#r, @r }; 
@ISA = qw(Perlbug::Do Perlbug::Utility); 
$| = 1; 

# internal utilities
use Perlbug; # version, debug and docs
use Perlbug::Config;
use Perlbug::Database;
use Perlbug::Do;
use Perlbug::Utility;
#use Perlbug::File; 
#use Perlbug::Object;
#use Perlbug::Relation;

# external utilities
# use Benchmark;
use Carp; 
use CGI qw(:standard);
use Data::Dumper;
# use Devel::Trace;
use HTML::Entities;
use Mail::Address;
use Email::Valid;

my %CACHE_OBJECT = ();
my %CACHE_SQL    = ();
my %CACHE_TIME   = ();
my %CACHE_BUGIDS = ();
my $o_CONF = undef;
my $o_DB   = undef;
my $o_LOG  = undef;

$Perlbug::i_LOG = 0;

sub new { 
    my $proto  = shift;
    my $class  = ref($proto) || $proto; 

	my $self = {};
    bless($self, $class);
	$self = $self->init(@_);

	return $self;
}

sub init {
	my $self = shift;

	# $self->clean_cache([], 'force');
	$self->clean_cache([]);

	# $o_CONF = $self->conf(@_); 
	# $CACHE_TIME{'INIT'} = Benchmark->new if $Perlbug::DEBUG;
	$Perlbug::i_LOG = 0;
	# %DB 	= $o_CONF->get_all('database');
	# $o_DB = Perlbug::Database->new(%DB); - always through->db()
	$o_LOG  = Perlbug::File->new($self->current('log_file'));

	$self->set_user($self->system('user'));	

    my $enabler = $self->system('enabled');
    if (!($enabler)) {     # OK 
        croak($self, "Enabler($enabler) disabled($Perlbug::VERSION) - not OK ($$ - $0) - cutting out!");
    } else {
		# $CACHE_TIME{'PREP'} = Benchmark->new if $Perlbug::DEBUG; 
		my $version = $self->version;
		my $userid  = $self->isadmin;
		$self->debug(0, "INIT $version ($$) debug($Perlbug::DEBUG) scr($0)  user($userid)") if $Perlbug::DEBUG; 

		my $i_obj = 0;
		my $preload = $self->system('preload');
		if ($preload) {
			my @objs = $self->objects();
			my $title = $self->system('title');
			foreach my $obj (@objs) { # 21+ (see below) 
				my $o_obj = $self->object($obj);
				$i_obj++ if ref($o_obj);
				$self->debug(3, "Base: $title $version loaded($i_obj) $obj object($o_obj)") if $Perlbug::DEBUG; 
			}
		}
		# $CACHE_TIME{'LOAD'} = Benchmark->new if $Perlbug::DEBUG;
	}

    return $self;
}

sub conf {
	my $self = shift;

	$o_CONF = ref($o_CONF) ? $o_CONF : Perlbug::Config->new(@_);

	return $o_CONF;
}

sub cgi {
	my $self = shift;
	my $req  = shift;

	my $cgi  = $self->{'_cgi'} || 'uninitialised';

	if (ref($req)) {
		$cgi = $self->{'_cgi'} = $req;
	}

	unless (ref($cgi)) {
		$req = '-nodebug' unless $0 =~ /cgi/; # context eq 'http'
		$cgi = $self->{'_cgi'} = CGI->new($req, @_);
	}
		
	return $cgi;
}

sub db { 
	my $self = shift; 
	
	$o_DB = ref($o_DB) ? $o_DB : Perlbug::Database->new($o_CONF->get_all('database'));

	return $o_DB;
}

sub log { 
	my $self = shift; 

	$o_LOG = ref($o_LOG) ? $o_LOG : Perlbug::File->new($self->current('log_file')); 

	return $o_LOG;
}

sub debug {
    my $self = shift;
    my $flag = shift;

	# confess("called($flag) DEBUG($Perlbug::DEBUG)");
	my $DATA = '';
	if (!(defined($flag) && $flag =~ /^[mMsSxX0123]$/o)) {
		$self->logg("XXX: unsupported call($self, $flag, data(@_)");
	} else {	
		# print "flag($flag) Perlbug::DEBUG($Perlbug::DEBUG)\n";
		if ($flag =~ /^[$Perlbug::DEBUG]$/) {
			$DATA = "@_";
			if ($Perlbug::DEBUG =~ /[mM23]/o) { # DATA 
				my @caller = caller();
				CALLER:
				foreach my $i (0..4) {
					@caller = caller($i);
					last CALLER if $caller[3] !~ /debug/i;
				}
				my $caller = $caller[3];
				$caller =~ s/^(?:\w+::)+(\w+)$/$1/ unless $Perlbug::DEBUG =~ /M/o; 
				$DATA = "$caller: @_ <= debug_flag($flag)"; 
			}
			$self->logg($DATA) if $DATA;
		}
    }
	return $DATA;
}

sub _debug {
	my $self = shift;
	return $self->logg(@_);
}

sub logg {
    my $self = shift if ref($_[0]);
    my @args = @_;
    my $data = "[$Perlbug::i_LOG] ".join(' ', @_, "\n"); 
    if (length($data) >= 13500) {
        $data = "Excessive data length(".length($data).") called!\n"; 
    }
	$self->log->append($data);
	# print $data if $0 =~ /bugdb/;
    $Perlbug::i_LOG++;
}

sub get_rand_msgid {
	my $self = shift;

	my $msgid = '<'.(join('_', 
		$self->system('title').'-tron',
		$$,
		rand(time).'@'.$self->email('domain'),
	)).'>';

	return $msgid;
}

sub splice {
    my $self  = shift;
	my $o_int = shift;

	my @data = ();
	if (!ref($o_int)) {	
		$self->debug(0, "Can't splice inappropriate mail($o_int) object")
	} else {
		# $o_int->remove_sig;
		@data = (
			$o_int->head,
			join('', @{$o_int->head->header}),
			join('', @{$o_int->body}),
		);
	}

	return @data;
}

sub object {
	my $self 	= shift;
	my $req  	= lc(shift);
	my $o_input = shift || '';
	my $type    = shift || '';
	my $o_obj 	= '';

	if (!$req) { 
		$self->error("requires a request($req) object: req($req) input($o_input) type($type)");
	} else { 
		if (ref($o_input)) {	# update cache
			my ($key, $hint) = ($o_input->attr('key'), $o_input->attr('hint'));
			if ($key eq $req || $hint eq $req) {
				$CACHE_OBJECT{$req} = $o_input; # x not parent/child x
			}
		}

		$o_obj = $CACHE_OBJECT{$req} if $self->system('cachable');

		if (!(ref($o_obj))) {	# get a new one
			my @args = ($self);
			my $request	= 'Perlbug::Object::'.ucfirst($req);
			if ($req =~ /^(\w+)\-\>(\w+)$/o) { # relation key
				$request = 'Perlbug::Relation'; 
				push(@args, $1, $2, $type);
			}
			my ($sep) = $self->system('separator');
			my $required = "$request.pm"; $required =~ s/::/$sep/g;
			# $DB::single=2;
			eval { require "$required" }; # :-\
			if ($@) {
				$self->error("failed to get req($req), request($request), required($required) $!\n");
			} else {
				$o_obj = $request->new(@args); 	# <-- !!!
				$CACHE_OBJECT{$req} = $o_obj;   # if $self->system('cachable');
				if (!(ref($o_obj))) { 
					$self->error("failed to request($req) object($o_obj) -> '$request->new(@args)' $!\n");
				}
			}
		}
	}

	$self->debug(3, qq|req($req), input($o_input), type($type) -> obj($o_obj)<br>\n|) if $Perlbug::DEBUG;
	return $o_obj;
}

sub version { return $Perlbug::VERSION; }

sub isatest { 
	my $self = shift;
	my $arg  = shift || '';
	my $res  = my $orig = $self->current('isatest');

	if ($arg =~ /^([01])$/o) {
		$res = $self->current({'isatest', $1});
	}

	$self->debug(2, "isatest($arg) orig($orig) => res($res)") if $Perlbug::DEBUG;

	return $res;
}

sub summary {
	my $self = shift;

	my $o_bug  = $self->object('bug');
	my $o_sta  = $self->object('status');
	my $o_bs   = $o_bug->rel('status');

	my ($oid)  = $o_sta->ids("name = 'open'");
	my $i_summ = $o_bug->count;
	my $i_open = $o_bs->count("statusid = '$oid'");

    my $sum = qq|$i_summ($i_open) bugs|;

	return $sum;
}

sub isframed {
	my $self = shift;

	return $self->current('framed');
}

sub myurl { # 
    my $self = shift;
    my ($url) = shift || $self->cgi->url;

	$url =~ s/[^_](perlbug\.cgi)/_$1/gsi unless $self->current('framed');
	exit if $url =~ /__/;

    if (defined($url)) { # may be blank
        $self->current({'url', $url});
    }
    return $self->current('url');
}

sub href {
	my $self = shift;

	my $o_obj = $self->object('bug');

	return $o_obj->href(@_);
}

# rjsf: Should be addresses()

sub dodgy_addresses { # context sensitive (in|out|to|from)
    my $self  = shift;
    my $scope = shift; # (from|to|cc|test...
	my $dodgy = '';

	my @duff  = (qw(MAILER-DAEMON postmaster)); 
	my @targs = $self->get_vals('target');
	my @frwds = $self->get_vals('forward');
	if ($scope =~ /^(from|sender)$/io) {					# FROM - don't accept mails from here
		push(@duff, @targs, @frwds,
				    $self->email('bugdb'),      $self->email('bugtron'));
	} elsif ($scope =~ /^(to|cc|reply-to)$/io) {			# TO   - don't send mails in this direction
		push(@duff, @targs, $self->email('bugdb'), $self->email('bugtron'));
	} elsif ($scope =~ /^test$/io) {						# TEST
		push(@duff, $self->email('test'), $self->target('test'), $self->forward('test'));
	} else { 											# ANY
		push(@duff); # could get paranoid :-)
	}
	chomp(@duff); # just in case

	DUFF:
    foreach my $duff ( map {split(/\s+/, $_) } @duff) {
        next unless $duff =~ /\w+/o;
        $dodgy .= quotemeta($duff).'|';
    }
    chomp $dodgy; # just in case again

    $dodgy =~ s/^(.+)?\|/$1/;
	$self->debug(3, "addresses($scope) -> '$dodgy'") if $Perlbug::DEBUG;

	return $dodgy; # regex 
}


sub format_overview {
	my $self = shift;
	my $ref  = shift;
	my $fmt  = shift || $self->current('format');
	return $self->SUPER::overview($ref, $fmt);
}

sub mypre {
	my $self = shift;
	my $fmt  = shift || $self->current('format');
	my $cxt  = $self->current('context');

	my $ret  = ($cxt =~ /^[hH]/o && $fmt =~ /[aAlixX]/o) ? '<pre>' : '';

	return $ret;
}

sub mypost {
	my $self = shift;
	my $fmt  = shift || $self->current('format');
	my $cxt  = $self->current('context');

	my $ret  = ($cxt =~ /^[hH]/o && $fmt =~ /[aAlixX]/o) ? '</pre>' : '';

	return $ret;
}

sub objects { # 
	my $self = shift;
	my $type = shift || '_%';

	my $cmp  = $self->db->comp($type);

	my @names = $self->object('object')->col('name', "type $cmp '$type'");

	return @names;
}

sub flags {
    my $self = shift;
    my $arg  = shift;
    my @flags = ();

	# my $types = join('|', qw(group osname project severity status version)); # yek
	my $types = join('|', ($self->object('object')->names("type = 'flag'"), 'group'));
    if ($arg !~ /^($types)$/) {
        $self->error("Can't get flags for invalid arg($arg)");
    } else {
		@flags = $self->object($arg)->col('name');
    }

    return @flags;
}

sub all_flags {
    my $self  = shift;
    my %flags = ();
	# my @types = qw(fixed group osname project severity status version); # yek
	my @types = ($self->object('object')->names("type = 'flag'"), 'group');
	foreach my $flag (@types) {
		my @flags = $self->flags($flag);
		$flags{$flag} = \@flags;        
    }
    return %flags;
}

sub date_hash {
    my $self = shift;
    my %dates = (
	    'any'               => '',
	    'today'             => ' TO_DAYS(SYSDATE()) - TO_DAYS(created) <= 1  ',
	    'this week'         => ' TO_DAYS(SYSDATE()) - TO_DAYS(created) <= 7  ',
	    'less than 1 month' => ' TO_DAYS(SYSDATE()) - TO_DAYS(created) <= 30 ',
	    'less than 3 months'=> ' TO_DAYS(SYSDATE()) - TO_DAYS(created) <= 90 ',
	    'over 3 months'     => ' TO_DAYS(SYSDATE()) - TO_DAYS(created) >= 90 ',
	);
    return %dates;
}

sub help {
    my $self = shift;

	my $email = $self->email('bugdb');
	my $url = $self->web('hard_wired_url');
	my $maintainer = $self->system('maintainer');
	my $title = $self->system('title');

	my $help = qq|
		A searchable live reference database of email-initiated bugs, patches and tests, etc.

		Email: $email

		WWW: $url 
		
        Comments, feedback, suggestions to: $maintainer.
		|;	

    return $help;
}

sub spec {
    my $self = shift;

	my $ehelp = $self->email('help');
	my $o_bug = $self->object('bug');
	my $o_usr = $self->object('user');
	my $o_status = $self->object('status');

	my $bids = $o_bug->count();
	my ($openid) = $o_status->name2id(['open']);
	my $open = my @open = $o_status->read($openid)->rel_ids('bug');
	my $admins = my @admins = $o_usr->ids("active = '1'");
	my ($bugdb, $cgi, $title) = ($self->email('bugdb'), $self->web('hard_wired_url'), $self->system('title'));
my $info = qq|
The $title bug tracking system $Perlbug::VERSION: $bids bugs ($open open). 

------------------------------------------

Anyone may search the database via the web:

		$cgi
				
or the email interface:
				
		To: $ehelp

------------------------------------------
		|;	

    return $info;
}

sub check_user { 
    #default administrator check (email uses from, web uses user/pass)
	my $self = shift;
	my $user = shift || 'generic';
	$self->debug(2, "check_user($user)") if $Perlbug::DEBUG;

	my $o_usr = $self->object('user');
    if ($self->system('restricted')) {
		my @ids = $o_usr->ids("userid = '$user' AND active IN ('1', '0')");
		$self->debug(2, "restricted ids(@ids)") if $Perlbug::DEBUG;
	    ID:
	    foreach my $id (@ids) {
			next if $id =~ /generic/io;
	        if (($id =~ /^\w+$/o) && ($id =~ /$user/)) {
				$self->current({'admin', $id});
	            $self->debug(1, "given param ($user) taken as admin id ($id)");
	            last ID;
	        } else {
				$self->debug(3, "unrecognised user($user) id($id)") if $Perlbug::DEBUG;
			}
        }
	} else {
        $self->current({'admin', $user});
	    $self->debug(1, "Non-restricted user($user) taken as admin id"); 
	}
	$self->debug(1, "check_user($user)->'".$self->isadmin."'") if $Perlbug::DEBUG;

	return $self->isadmin;
}

sub isadmin { # retrieve admin flag (and id)
    my $self = shift;

    my ($user) = ($self->system('restricted')) 
		? grep(!/generic/i, $self->current('admin')) 
		: $self->current('admin');

	$self->debug(3, "user($user)") if $Perlbug::DEBUG;

    return $user;
}

sub isbugmaster { # retrieve bugmaster id
    my $self = shift;

	my $user = $self->isadmin;
	my $bugm = $self->system('bugmaster');

	$self->debug(2, "user($user) bugm($bugm)") if $Perlbug::DEBUG;

	return ($user eq $bugm) ? $user : ();
}

sub switches { # admin|user
    my $self = shift;
	my $arg  = shift || '';
	my @switches = ();

	my @admin = split(//, $self->system('admin_switches'));
	my @user  = split(//, $self->system('user_switches'));

	if ($arg eq 'admin') {
		@switches = @admin;
	} elsif ($arg eq 'user') {
		@switches = @user;
	} else {
		@switches = ($self->isadmin) ? (@admin, @user) : @user;
	}

	@switches = sort grep(/^\w$/, @switches);
	
	$self->debug(2, "in($arg) out(".join(', ', @switches).')') if $Perlbug::DEBUG;

    return @switches;
}

sub create {
    my $self = shift;
    my $file = shift;
    my $data = shift;
	my $perm = shift || '0766';
	my $o_file = '';
    
    # ARGS
    if (!(($file =~ /\w+/o) && ($data =~ /\w+/o))) {
        $self->errors("Duff args given to create($file, $data, $perm)");
    } else {
    	$o_file = Perlbug::File->new($file, '>', $perm);
        if (ref($o_file)) {
			$o_file->append($data);
        } else {
            $self->error("failed to create file($file) -> o_file($o_file)");
        }
    }
    
    return $o_file;
}

sub xprioritise {
    my $self = shift;
    # return "";  # disable
    my ($priority) = ($_[0] =~ /^\d+$/o) ? $_[0] : 12;
	my $pre = getpriority(0, 0);
	setpriority(0, 0, $priority);
	my $post = getpriority(0, 0);
	$self->debug(2, "Priority($priority): pre ($pre), post ($post)") if $Perlbug::DEBUG;
	return $self;
}

sub set_user {
    my $self = shift; # ignored
    my $user = shift;
    my $oname  = getpwuid($<); 
    my $original = qq|orig($oname, $<, [$(])|;
    my @data = getpwnam($user);
    ($>, $), $<, $() = ($data[2], $data[3], $data[2], $data[3]);
    my $pname  = getpwuid($>); 
    my $post = qq|curr($pname, $<, [$(])|;
	$self->debug(2, "pre($original) current($post)") if $Perlbug::DEBUG;
	return $self;
}

sub read {
    my $self = shift;
	my $tgt  = shift;

	my $file = $self->target2file($tgt);
	if (!(-e $file)) {
		$self->error("can't read duff target($tgt) file($file): $!");
	} else {
		my $o_file = Perlbug::File->new($file, '<');
        if (!defined ($o_file)) {
            $self->error("failed to prep read of file($file) -> o_file($o_file)");
        } else {
			return $o_file->read();
        }
	}
 
	return ();
}

sub target2file {
	my $self = shift;
	my $tgt  = shift;
	my $file = '';

	if ($tgt !~ /\w+/) {
		$self->error("can't remap duff target($tgt)!");
	} else {
		$file = $self->directory('text').$self->system('separator').$tgt;
	}

	return $file;
}

sub clean_cache {
	my $self = shift;
	my $tgt  = shift;
	my $force= shift || '';

	if ($tgt !~ /\w+/) {
		$self->error("requires target($tgt) to clean and optional force($force)?");
	} else {
		if (ref($tgt) eq 'ARRAY') { # flush
			%CACHE_BUGIDS = ();
			%CACHE_OBJECT = ();
			%CACHE_SQL    = ();
			%CACHE_TIME   = ();
		} else {
			%CACHE_BUGIDS = () if $tgt =~ /bugids/io && ($force || !$self->system('cachable')); 
			%CACHE_OBJECT = () if $tgt =~ /object/io && ($force || !$self->system('cachable')); 
			%CACHE_SQL    = () if $tgt =~ /sql/io  	 && ($force || !$self->system('cachable')); 
			%CACHE_TIME   = () if $tgt =~ /time/io   && ($force || !$self->system('cachable')); 
		}
	}	

    return $self;
}

sub get_list {
	my $self = shift;
	my $sql  = shift; 
	my $refresh = shift || '';

	return $self->get_data($sql, $refresh, 'list');
}

sub get_data {
	my $self = shift;
	my $sql  = shift;	
	my $refresh = shift || '';
	my $list    = shift || '';

	my $a_info = [];
	my $a_cache = $CACHE_SQL{$sql}; # unless $refresh;

	if (defined($a_cache) && ref($a_cache) eq 'ARRAY' && $refresh !~ /\w+/o) { 
		$a_info = $a_cache;
		$Perlbug::Database::CACHED++;
		$self->debug('s', "sql:  cached($a_cache) <= SQL($sql)") if $Perlbug::DEBUG;
	} else {
		$a_cache = ' ' x 16; 
		$self->debug('s', "sql: initial($a_cache) <= SQL($sql)") if $Perlbug::DEBUG;
		my $sth = $self->db->query($sql);
 		if (!defined($sth)) {
        	$self->error("undefined cursor for get_data: '$DBI::errstr'");
    	} else {
			if ($list eq 'list') {
				while ( (my $info) = $sth->fetchrow) { #? fetchrow.$ref(_hashref)
					push (@{$a_info}, $info) if defined $info;
				}
			} else {
				while (my $info = $sth->fetchrow_hashref) { # 
					push (@{$a_info}, $info) if ref($info) eq 'HASH';
				}
			}
			# $self->rows($sth);
			$CACHE_SQL{$sql} = $a_info if $self->system('cachable');
			$self->debug('S', "sql:  stored($a_cache) <= SQL($sql)") if $Perlbug::DEBUG;
    		$self->debug('S', 'found '.$sth->rows." rows($a_info): ".Dumper($a_info)) if $Perlbug::DEBUG;
    	}
		undef $sth;
	}
	# $self->debug('S', $a_info) if $Perlbug::DEBUG;
	return @{$a_info}; 
}    

sub exec {
	my $self = shift;
	my $sql  = shift;

	$self->debug('x', $sql) if $Perlbug::DEBUG;

	my $i_ok = 0;
	my $sth = $self->db->query($sql);
	if (defined($sth)) { 
		$i_ok++;
		my $i_rows = $sth->rows;
		$self->debug('X', "affected rows($i_rows)") if $Perlbug::DEBUG;
	} else {
	    $self->error("Exec($sql) error: $Mysql::db_errstr");
	}

	return $sth;
}

sub extant {
	my $self = shift;
	my $bugid = shift || '';
	
	$CACHE_BUGIDS{$bugid}++ if $bugid;

	return keys %CACHE_BUGIDS;
}

sub exists {
	my $self = shift;
	my $bid = shift || '';
	
	my $i_ok = ($self->object('bug')->exists([$bid])) ? 1 : 0;

	return $i_ok;
}

sub notify {
	my $self = shift;
	my $obj  = shift;
	my $oid  = shift;
	my $i_ok = 0;

	if (!($obj =~ /^\w+$/o && $oid =~ /\w+/o)) {
		$self->error("requires valid object($obj) and id($oid)!");
	} else {
		my $o_obj = $self->object($obj)->read($oid);
		if (!($o_obj->READ)) {
			$self->error("requires valid object($obj) and id($oid)!");
		} else {
			my $header = $o_obj->data('header');
			my $body   = $o_obj->data('body');

			if (!$self->current('mailing')) {
				$self->debug(0, "not mailing(".!$self->current('mailing').")") if $Perlbug::DEBUG;
			} else {
				my $o_int = $self->setup_int($header, $body);
				my ($o_hdr, $header, $body) = $self->splice($o_int);
				if (!ref($o_hdr)) {
					$self->debug(0, "no header($o_hdr) for notification!") if $Perlbug::DEBUG;
				} else {
					my ($from, $orig, $replyto, $subject, $to) = ('', '', '', '', '');
					my @cc   = $o_hdr->get('Cc'); @cc = () unless @cc;
					$from    = $o_hdr->get('From');
					$orig    = $o_hdr->get('Subject');
					$replyto = $o_hdr->get('Reply-To');
					$to      = $o_hdr->get('To');
					chomp(@cc, $from, $orig, $replyto, $subject, $to); 
					$subject  = ($obj =~ 'bug' ? '' : ucfirst($obj))." [ID $oid] $orig";

					my $o_email = Perlbug::Interface::Email->new;

					# ACKNOWLEDGE - noack
					if (grep(/noack/io, $to, @cc) || $body =~ /(ack(knowledge)*=no)/iso) {
						$self->debug(1, "body(to|cc) contains ack(\w+)=no -> not acknowledging!") if $Perlbug::DEBUG;
					} else {
						$self->debug(1, "body(to|cc) doesn't contain ack(\w+)=no -> acknowledging") if $Perlbug::DEBUG;
						my $o_ack = $o_email->get_header($o_hdr);
						$o_ack->replace('Subject', "Ack - $subject");
						$o_ack->replace('To', $o_email->from($replyto, $from)); 
						my $response = join('', $o_email->read('response'));
						my $footer   = join('', $o_email->read('footer'));
						$response =~ s/(An ID)/A $obj ID ($oid)/;	    # clunk
						$response =~ s/(Original\ssubject:)/$1 $orig/;	# clunk
						$i_ok = $o_email->send_mail($o_ack, $response.$footer);
					}

					# NOTIFY - nocc
					if (grep(/no(cc|notify)/io, $to, @cc)) {
						$self->debug(1, "to($to), cc(@cc) contains no(cc|notify) -> not notifying!") if $Perlbug::DEBUG;
					} else {
						$self->debug(1, "to($to), cc(@cc) doesn't contain no(cc|notify) -> notifying") if $Perlbug::DEBUG;
						my @ccs = ($obj eq 'bug' ) ? $self->bugid_2_addresses($oid, 'new') : ();
						$o_hdr  = $o_email->addurls($o_hdr, $obj, $oid);
						$o_hdr->replace('Subject', $subject);
						my $type = ($subject =~ /^\s*OK/io) ? 'ok' : 'remap';
						my $o_notify = $o_email->get_header($o_hdr, $type);	
						$o_notify->replace('Cc', join(', ', @ccs));
						$i_ok = $o_email->send_mail($o_notify, $body); # auto
					}
				}
			}
		}
    }

	return $i_ok;
}

sub setup_int {
	my $self   = shift;
	my $header = shift || '';
	my $body   = shift || 'no-body-given';
	my $o_int  = undef;
	
	my %header   = ();
	if (ref($header) eq 'HASH') {
		%header = %{$header};
	} else {
		if ($header =~ /^([^:]+:\s*\w+.*)/mo) { 
			$header =~ s/\r?\n\s+/ /gos; # unfold
			%header = ($header =~ /^([^:]+):(.*)$/gmo);	
		} else { 
			$self->debug(0, "Can't setup int from invalid header($header)!");
		}
	}

	if (keys %header) {
		my $o_hdr = Mail::Header->new;
		TAG:
		foreach my $tag (keys %header) {
			my @tags = (ref($header{$tag})) eq 'ARRAY' ? @{$header{$tag}} : ($header{$tag});
			$tag =~ tr/\n/ /d; # strays
			if ($tag =~ /^\w+(\-\w+)*/) {
				$o_hdr->add($tag, @tags);
			} else {
				$self->debug(0, "*** problem with tag($tag)!");
			}
		}
		$o_hdr->add('Message-Id', $self->get_rand_msgid) unless $o_hdr->get('Message-Id'); 
		$o_hdr->add('Subject', q|some irrelevant subject|) unless $o_hdr->get('Subject'); 

		$o_int = Mail::Internet->new(
			'Header' => $o_hdr, 
			'Body' => [map { "$_\n" } split("\n", $body)]
		);
		my $to   = $o_int->head->get('To') || '';
		my $from = $o_int->head->get('From') || ''; 
		if (!($to =~ /\w+/o && $from =~ /\w+/o)) { 
			$self->debug(0, "Invalid mail($o_int) via header: ".Dumper(\%header));
			$self->debug(0, "to($to) from($from)".Dumper($o_int->head));
			undef $o_int;
		}
	}

	return $o_int;
}

sub notify_cc {
	my $self  = shift;
	my $bid   = shift;
	my $orig  = shift || '';
	my $i_ok  = 1;

	$self->clean_cache([]);
	my $o_bug = $self->object('bug');

	if (!($o_bug->ok_ids([$bid]) and $self->exists($bid))) {
		$i_ok = 0;
		$self->error( "notify_cc requires a valid bugid($bid)");
	} else {
		my $bugdb = $self->email('bugdb');
		my $url = 'http://'.$self->web('domain').'/'.$self->web('cgi')."?req=bug_id&bug_id=$bid\n";
		my ($bug) = $o_bug->read($bid)->format('a'); # a bit less more data :-)
		my $diff = $o_bug->diff($orig, $bug);
		my $status = qq|The status of bug($bid) has been updated:
$bug

The difference from the original:
$diff
				|;
		$status .= qq|
To see this (and more) data on the web, visit:

		$url

				|;
		my ($addr) = $o_bug->col('sourceaddr');
		my ($o_to) = Mail::Address->parse($addr);
		my ($to) = (ref($o_to)) ? $o_to->format : $self->system('maintainer');
		my @ccs = $self->bugid_2_addresses($bid, 'update');
		use Perlbug::Interface::Email; # yek
		my $o_email = Perlbug::Interface::Email->new;
		my $o_notify = $o_email->get_header($o_bug->data('header'));
		$o_notify->add('To', $to);
		# $o_notify->add('Cc', join(', ', @ccs)) unless grep(/nocc/i, @unknown, @versions);
		$o_notify->add('From', $self->email('bugdb'));
		$o_notify->add('Subject', $self->system('title')." $bid status update");
		$i_ok = $o_email->send_mail($o_notify, $status) if $self->current('mailing') == 1;
		$self->debug(3, "notified($i_ok) <- ($bid)") if $Perlbug::DEBUG;
	}

	return $i_ok;
}

sub todo {
	my $self  = shift;
	my $todo  = shift;

	my $i_ok  = 1;
	if ($todo !~ /\w+/) {
		$i_ok = 0;
		$self->error("requires a something todo($todo)");
	} else {
		my $fmt = $self->current('format');
		$self->current({'format', 'a'});
		my $to = $self->system('maintainer');
		require Perlbug::Interface::Email; # yek
		my $o_email = Perlbug::Interface::Email->new;
		my $o_todo = $o_email->get_header;
		$o_todo->add('To', $to);
		$o_todo->add('From', $self->email('bugdb'));
		$o_todo->add('Subject', $self->system('title')." todo request");
		$i_ok = $o_email->send_mail($o_todo, $todo);
		$self->debug(3, "todo'd($i_ok) <- ($todo)") if $Perlbug::DEBUG;
		$self->current({'format', $fmt});
	}

	return $i_ok
}

sub track {
	my $self 	= shift;
	my $key     = shift;
	my $id		= shift;
	my $entry	= shift; # 

	my $userid  = $self->isadmin;
	my ($quoted)= $self->db->quote($entry);

	my $insert = qq|INSERT INTO pb_log SET 
				created		= SYSDATE(),
				modified	= SYSDATE(),
				entry		= '$quoted', 
				userid		= '$userid', 
				objectid	= '$id', 
				objectkey	= '$key'
		|;	

	# $o_log->create($track);
	my $sth = $self->db->query($insert);
	if (!defined($sth)) {
		$self->error("track failure ($insert) -> result($sth)");
	}		

	return $sth;
}

sub ck822 {
    my $self = shift;
    my $addr = shift;

	my $i_ok = 0;
    if (!(Email::Valid->address($addr))) {
		$self->debug(0, "rfc822 failure on '$addr'") if $Perlbug::DEBUG; 
	} else {
		$i_ok++;
		$self->debug(3, "rfc822 success on '$addr'") if $Perlbug::DEBUG; 
	}

	return $i_ok;
}

sub htpasswd { #
    my $self = shift;
    my $user = shift;
    my $pass = shift; 

    my $htpw = $self->directory('config').'/.htpasswd';
    $self->debug(1, "htpasswd($user, $pass) with($htpw)") if $Perlbug::DEBUG;

	$self->debug(0, "htpasswd update disabled") if $Perlbug::DEBUG;
	print "FYI: htpasswd update disabled<br>\n";
	return (); # disabled

    my @data = $self->log->copy($htpw, $htpw.'.bak', '0660'); # backitup

    my $i_ok = 1;
    if (!(scalar(@data) >= 1)) {
        $self->error("copy($htpw, $htpw.'.bak') must have failed?");
    } else {
		my $htpass = join('', grep(/\w+/, @data));
        $self->debug(2, "Existing htpasswd file: '$htpass'") if $Perlbug::DEBUG;
        if (!(($user =~ /^\w+$/o) && ($pass =~ /\w+/o))) {
			$i_ok = 0;
            my $err = "Can't open htpasswd file($htpw)! $!";
            $self->error($err);
        } else {
            $self->debug(1, "HTP: working with user($user) and pass($pass)") if $Perlbug::DEBUG;
            if ($htpass !~ /^$user:(.+)$/m) {	# modify?
                $htpass .= "$user:$pass\n";
                $self->debug(1, "HTP: adding new user($user) / pass($pass)") if $Perlbug::DEBUG;
            } else {                        	# add!
                my $found = $1;
                $self->debug(3, "found($found)") if $Perlbug::DEBUG;
                if ($found ne $pass) {
                    $htpass =~ s/^$user:(.+)$/$user:$pass/m;
                    $self->debug(1, "HTP: changing user($user) found($found) to pass($pass)") if $Perlbug::DEBUG;
                } else {
                    $self->debug(1, "Not changing user($user) or pass($pass) with found($found)") if $Perlbug::DEBUG;
                }
            } 
            $htpass =~ s/^\s*$//gmo; 
			$i_ok = $self->create($htpw, $htpass, '0660'); # file
            $self->debug(3, "Modified($i_ok) htpasswd file: '$htpass'") if $Perlbug::DEBUG;
    	}
    }
    $self->debug(1, "user htpasswd update($i_ok)") if $Perlbug::DEBUG;

    return $i_ok; # (wantarray ? @data : $i_ok);
}

sub help_ref {
	my $self = shift;
	my $targ = shift || '';
	my $title= shift || $targ; 
    my $url  = $self->myurl;

	my $sect = ($targ =~ /\w+/o) ? '#item_'.$targ : '';
	my $with = ($targ =~ /\w+/o) ? "help with $targ parameters" : 'general help overview';
	my $hint = "click for $with";
	my $help = qq|<a 
						href="$url?req=webhelp$sect"
						onMouseOver="window.status='$hint';" 
						onClick="return go('webhelp$sect');"
						onMouseOut="window.status='';"
				>$title</a>
		|;
	$help =~ s/\s*\n+\s*/ /go;
	return "$help\n";
}

sub clean_up {
    my $self = shift;
    my $max  = shift || $self->system('max_age');
    $self->debug(3, "clean_up($max)") if $Perlbug::DEBUG;
	my $found = 0;
    my $cleaned = 0;

	# $self->tell_time() if $Perlbug::DEBUG;

	my $o_range = $self->object('range');
	my @defunct = $o_range->ids("TO_DAYS(modified) < (TO_DAYS(SYSDATE()) -10)");
	$self->debug(3, "deletable ranges(@defunct)") if $Perlbug::DEBUG;
	# $o_range->delete(\@defunct);
	# $o_range->relation('bug')->delete(\@defunct);
	if ($max =~ /^\d+/o) {
		foreach my $DIR (qw(logs temp)) { # 
			my $dir = $self->directory('spool')."/$DIR";
			$self->debug(3, "cleaning($dir)") if $Perlbug::DEBUG;
        	if (-d $dir) {
	    		my ($remcnt, $norem) = (0, 0); 
	    		opendir DIR, $dir or $self->error("Can't open dir ($dir) for clean up $!");
	    		my @files = grep(/\w+\.\w+$/, readdir DIR);
	    		$found += scalar(@files);
				$self->debug(3, 'Found: '.scalar(@files).' files') if $Perlbug::DEBUG;
	    		close DIR;
	    		foreach my $file (@files) {
	        		next unless -f "$dir/$file";
	        		my $FILE = "$dir/$file";
	        		if (-M $FILE >= $max) { # remove file if old 
	            		if (!unlink($FILE)) {
	                		$self->error("Unable to remove file '$FILE' $!");
	                		$norem++;
	            		} else {
	                		$self->debug(3, "Removed ($FILE)") if $Perlbug::DEBUG;
	                		$remcnt++;
	            		}
	        		} else {
	            		$self->debug(3, "Ignoring recent file '$FILE'") if $Perlbug::DEBUG;
	        		}
	    		}
            	$self->debug(3, "Process ($$): dir($dir) fertig: rem($remcnt), norem($norem) of ".@files) if $Perlbug::DEBUG;
            	$cleaned += $remcnt;
        	} else {
            	$self->error("Can't find directory: '$dir'");
        	}   
		}
    }
    $self->debug(3, "Cleaned up: age($max) -> files($cleaned) of($found)") if $Perlbug::DEBUG;
	
	return ();
}

sub tell_time {
	my $self = shift;
	my $feedback = ' ';

	if ($Perlbug::DEBUG) {
		my $now  = shift || Benchmark->new; 

		$CACHE_TIME{'DONE'} = $now;

		my $start = $CACHE_TIME{'INIT'} || 0;
		my $prep  = $CACHE_TIME{'PREP'} || 0;
		my $load  = $CACHE_TIME{'LOAD'} || 0;
		my $done  = $CACHE_TIME{'DONE'} || 0;
		my $x = qq|start($start), prep($prep), load($load), done($done)|;

		my $started = timediff($prep, $start);
		my $loaded  = timediff($load, $prep);
		my $runtime = timediff($done, $load);
		my $total   = timediff($done, $start);

		$feedback = ($started && $loaded && $runtime && $total) 
			? qq|$0 debug($Perlbug::DEBUG)
				Startup: @{[timestr($started)]}
				Loaded : @{[timestr($loaded)]}
				Runtime: @{[timestr($runtime)]}
				Alltook: @{[timestr($total)]}
						with $Perlbug::Database::SQL SQL statements 
						used $Perlbug::Database::HANDLE database handle/s
						cach $Perlbug::Database::CACHED queries
				|
			: '';
		$self->debug(1, $feedback) if $Perlbug::DEBUG;
	}

	return $feedback;
} 

sub parse_str {
	my $self = shift;
	my $str  = shift;
	my @args = split(/(\s|_)+/o, $str);
	my %cmds = (); 
	
	my $o_bug = $self->object('bug');
	my @flags = grep(!/fixed/io, $self->objects('flag'), 'group', 'user');
	my @names = map { substr($_, 0, 4) } map { $self->object($_)->col('name') } @flags;
	my %seen  = ();

	ARG:
	foreach my $arg (@args) {
		next ARG unless $arg =~ /\w+/o;
		next ARG if $seen{$arg};
		my $arg4 = substr($arg, 0, 4);
		# print "arg($arg) => arg4($arg4)<hr>";
		if ($o_bug->ok_ids([$arg])) {	# bugid
			push(@{$cmds{'bug'}{'ids'}}, $arg);
		} elsif (grep(/^\Q$arg4/i, @names)) {				
			foreach my $flag (@flags) {					# flag
				my $o_obj = $self->object($flag);
				my @types = $o_obj->col('name');
				my ($argtype) = ($flag =~ /^(group|severity|status|userid)$/io) 
					? grep(/^$arg/i, @types) 	# loose 
					: grep(/^$arg$/i, @types);	# tighter (eg; osname...)
				if ($argtype =~ /\w+/o) {			    # type 
					my ($id) = $o_obj->name2id([$arg]);
					push(@{$cmds{$flag}{'ids'}}, $id) if $id;
					push(@{$cmds{$flag}{'names'}}, $argtype);
				}
			}
		} else {										# unknown
			my $key = ($arg	=~ /^\d+$/o) ? 'ids' : 'names';
			push(@{$cmds{'unknown'}{$key}}, $arg);
		}
		$seen{$arg}++;
	}
	# $DB::single=2;
	$self->debug(1, "parse in($str), out-> ".Dumper(\%cmds)) if $Perlbug::DEBUG;

	return %cmds;
}

sub scan { # ids/names
    my $self    = shift;
    my $body    = shift;
    my %data 	=  (); 

    my $i_cnt   = 0;
	$self->debug(2, "Scanning mail (".length($body).")") if $Perlbug::DEBUG;
    my %flags = $self->all_flags;
	$flags{'category'} = $flags{'group'};

	LINE:
    foreach my $line (split(/\n/, $body)) {         # look at each line for a type match
        $i_cnt++;
		next LINE unless $line =~ /\w+/o;
		$self->debug(2, "LINE($line)") if $Perlbug::DEBUG;
		TYPE:
        foreach my $type (keys %flags) {     					# status, group, severity, version...
            $self->debug(2, "Type($type)") if $Perlbug::DEBUG;
            my @setindb = @{$flags{$type}} if ref($flags{$type}) eq 'ARRAY';
            $self->debug(2, "Setindb(@setindb)") if $Perlbug::DEBUG;
			SETINDB:
			foreach my $indb (@setindb) {                   	# open closed onhold, core docs patch, linux aix...
				next SETINDB unless $indb =~ /\w+/o;
				next SETINDB if $type eq 'version' && $indb !~ /\d$/;
				if ($line =~ /\s*$type\s*=\s*(?:3d){0,1}\s*($indb)\s*/i) {			# osname=(3d)*winnt|macos|aix|linux|...
					$data{$type}{lc($1)}++;
					$self->debug(2, "Bingo: flag($type=$1)") if $Perlbug::DEBUG;
					# next TYPE; tut tut - we want all we can get
				}	
			} 

			my @matches = $self->get_keys($type);               # SET from config file
            $self->debug(2, "Matches(@matches)") if $Perlbug::DEBUG;
			MATCH:
			foreach my $match (@matches) {                  	# \bperl|perl\b, success\s*report, et
				next MATCH unless $match =~ /\w+/o;
				$self->debug(2, "Match($match)?") if $Perlbug::DEBUG;
				if ($line =~ /$match/i) {                   	# to what do we map?
					if ($type eq 'version') {               	# bodge for version
						$^W = 0;
						my $num = $1.$2.$3.$4.$5;				#
						$^W = 1;
						if ($num =~ /^\d[\d\.]+?\d$/o) {
							$data{$type}{$num}++;
							my $proj = $num;
							$proj =~ s/^(\d).*/$1/;
							$data{'project'}{"perl$proj"}++;
							$self->debug(1, "Bingo: line($line) version ($num) proj($proj)-> next LINE") if $Perlbug::DEBUG;
							next TYPE;
						}
					} else { # attempt to set flags based on data found
						next MATCH unless $line =~ /=/o;		# short circuit
						my $target = $self->$type($match);  	# open, closed, etc.
						if (grep(/^$target/i, @setindb)) {  	# do we have an assignation?
							$data{$type}{lc($target)}++;
							$self->debug(1, "Bingo: target($target) -> next LINE") if $Perlbug::DEBUG;
							next TYPE;
						}
					}
				}
			}

		}
    }

	# workaround for category/group mish-mash
	if ($data{'category'}) {
		$data{'group'} = (ref($data{'group'})) 
			? { %{$data{'group'}}, %{$data{'category'}} } 
			: { %{$data{'category'}} }; 
		delete $data{'category'};
	}

	# convert to parse_str style
	my %rel = ();
	foreach my $key (keys %data) {
		# $data{$key} = [$self->default_flag($key)] unless ref($data{$key}) eq 'ARRAY'; 
		push(@{$rel{$key}{'names'}}, keys %{$data{$key}});
	}
	$rel{'status'}{'names'} = [qw(open)] unless ref($rel{'status'}{'names'}) eq 'ARRAY';

    my $rel = scalar keys %rel;
    $self->debug(2, "Scanned count($i_cnt), found($rel): ".$self->dump(\%rel)) if $Perlbug::DEBUG;  

    return \%rel;
}

sub bugid_2_addresses {
    my $self  = shift;
    my $bid   = shift;
    my $context = shift || 'auto'; # or new|update...

    my $feedback = $self->feedback($context); # (active|admin|cc|maintainer|group|master|source)
    $self->debug(2, "generating bugid($bid) context($context) feedback($feedback)") if $Perlbug::DEBUG; 
    my @addrs = ();
    my $o_bug = $self->object('bug')->read($bid);

	if ($o_bug->READ) {
		my $o_grp = $self->object('group');
		my $o_usr = $self->object('user');

		if ($bid !~ /\w+/) {
			$self->debug(1, "require bugid($bid)") if $Perlbug::DEBUG;
		} else {
			if ($feedback =~ /active/o) {
				my @active = $o_usr->col('address', "active='1'");
				push(@addrs, @active);
			}
			if ($feedback =~ /admin/o) {
				my @uids = $o_bug->rel_ids('user');
				if (@uids) {
					my @admins = map { $o_usr->read($_)->data('address') } @uids;
					push(@addrs, @admins);
				}	
			}
			if ($feedback =~ /maintainer/o) {
				push(@addrs, $self->system('maintainer'));
			}
			if ($feedback =~ /cc/o) {
				my @ccs = $o_bug->rel_ids('address');
				push(@addrs, @ccs);
			}
			if ($feedback =~ /group/o) {
				my $gid = $o_bug->rel_ids('group');
				if ($gid) {
					# print "gid($gid)".$o_bug->format;
					my @uids = $o_grp->read($gid)->rel_ids('user');
					if (@uids) {
						my @gaddrs = map { $o_usr->read($_)->data('address') } @uids; 
						push(@addrs, @gaddrs);
					}
				}
			}
			if ($feedback =~ /source/o) { # always
				my ($srcaddr) = $o_bug->data('sourceaddr');	
				push(@addrs, $srcaddr);
			}
		}
    }

    return @addrs;
}

sub compare {           # 
	my $self = shift;
    my ($first, $second) = @_;
	local $^W = 0;  # silence spurious -w undef complaints
	return 0 unless @$first == @$second;
	for (my $i = 0; $i < @$first; $i++) {
    	return 0 if $first->[$i] ne $second->[$i];
	}
	return 1;
}

sub AUTOLOAD {
	my $self = shift;

	my $meth = $AutoLoader::AUTOLOAD = $AUTOLOAD;

    return if $meth =~ /::DESTROY$/io; 
    $meth =~ s/^(.*):://o;

	# if ($meth =~ /^debug(\w)$/) {
	#	return $self->debug($1, @_); # migration debug(2, $msg) => debug2($msg) support
	# } else {
		return $self->conf->$meth(@_); 
	# }
}


$SIG{'INT'} = sub {
	carp "Perlbug interupted: bye bye!";
	exit(1);	
};

# 
1;