my %builtin_cmds = (
history => {
- help => 'history [<start> <end>]',
- description => 'Displays cmd history. You can specify where to <start> and where to <end>.
-Default is to list only the last screen full lines of history
-(as denoted by $LINES).'
+ help => 'history [[start] [end]]',
+ description =>
+ "Displays cmd history. You can specify where to <start> and where to <end>\n"
+ . "Default is to list only the last screen full lines of history (as denoted\n"
+ . "by \$LINES).",
},
help => {
description => 'Displays help.',
},
+ helpall => {
+ help => 'helpall',
+ description => 'Display all help, including builtin commands',
+ },
+
savehist => {
- help => 'savehist <file> [<start> <end>]',
- description => 'Saves a section of the history to a file. You can specify where to <start>
-and where to <end>. Default is to save all of the history to
-the specified file.',
+ help => 'savehist [file] [[start] [end]]',
+ description =>
+ "Saves a section of the history to a file. You can specify where to <start>\n"
+ . "and where to <end>. Default is to save all of the history to the specified\n"
+ . "file.",
},
get => {
- help => 'get <var>',
+ help => 'get [var]',
description => 'Gets a variable.',
},
set => {
- help => 'set <var>=<expression>',
- description => 'Sets a variable. Note that expression can be any valid expression.',
+ help => 'set [var]=[expression]',
+ description =>
+ 'Sets a variable. Note that expression can be any valid expression.',
},
vars => {
help => 'vars',
- description => 'Displays all known variables.',
+ description =>
+ 'Displays all known variables.',
},
source => {
- help => 'source <file>',
- description => 'Run commands from a file.',
+ help => 'source [file]',
+ description =>
+ 'Run commands from a file.',
},
color => {
- help => 'color [<on|off>]',
- description => 'Turn on|off color. With no options displays status of color.',
+ help => 'color [(on|off)]',
+ description =>
+ 'Turn on|off color. With no options displays status of color.',
},
trace => {
- help => 'trace [<on|off>]',
- description => 'Turn on|off tracing. With no options displays status of trace.',
+ help => 'trace [(on|off)]',
+ description =>
+ 'Turn on|off tracing. With no options displays status of trace.',
},
);
-sub _cmdCompletion ($$) {
+sub _cmdCompletion($$) {
my ($text, $state) = @_;
return unless %_cmds;
return;
} # _cmdCompletion
-sub _complete ($$$$) {
+sub _complete($$$$) {
my ($text, $line, $start, $end) = @_;
- return $_cmdline->completion_matches ($text, \&CmdLine::_cmdCompletion);
+ return $_cmdline->completion_matches($text, \&CmdLine::_cmdCompletion);
} # _complete
-sub _gethelp () {
+sub _gethelp() {
my ($self) = @_;
return unless %_cmds;
# Sometimes we are called by ReadLine's callback and can't pass $self
if (ref $self eq 'CmdLine') {
- $self->help ($line);
+ $self->help($line);
} else {
- $CmdLine::cmdline->help ($line);
+ $CmdLine::cmdline->help($line);
} # if
$_cmdline->on_new_line;
+
+ return;
} # _gethelp
-sub _interpolate ($) {
+sub _interpolate($) {
my ($self, $str) = @_;
# Skip interpolation for the perl command (Note this is raid specific)
my $varname = $1;
if (defined $self->{vars}{$varname}) {
- if ($self->{vars}{$varname} =~ / /) {
- $str =~ s/\$$varname/\'$self->{vars}{$varname}\'/;
- } else {
+ if ($self->{vars}{$varname} =~ / /) {
+ $str =~ s/\$$varname/\'$self->{vars}{$varname}\'/;
+ } else {
$str =~ s/\$$varname/$self->{vars}{$varname}/;
- } # if
+ } # if
} else {
- $str =~ s/\$$varname//;
+ $str =~ s/\$$varname//;
} # if
} # if
} # while
return $str;
} # _interpolate
-sub _builtinCmds ($) {
+sub _builtinCmds($) {
my ($self, $line) = @_;
- unless (defined $line) {
+ unless ($line) {
display '';
return 'exit';
} # unless
return
unless $cmd;
- my @parms;
-
# Search for matches of partial commands
my $foundCmd;
- for (keys %builtin_cmds) {
+ for (keys %builtin_cmds) {
if ($_ eq $cmd) {
# Exact match - honor it
$foundCmd = $cmd;
} # if
if ($builtin_cmds{$cmd}) {
- if ($line =~ /^\s*help\s*(.*)/i) {
+ if ($line =~ /^\s*helpall\s*$/i) {
+ $self->help('', 1);
+ } elsif ($line =~ /^\s*help\s*(.*)/i) {
if ($1 =~ /(.+)$/) {
- $self->help ($1);
+ $self->help($1);
} else {
$self->help;
} # if
} elsif ($line =~ /^\s*history\s*(.*)/i) {
if ($1 =~ /(\d+)\s+(\d+)\s*$/) {
- $self->history ('list', $1, $2);
+ $self->history('list', $1, $2);
} elsif ($1 =~ /^\s*$/) {
- $self->history ('list');
+ $self->history('list');
} else {
error "Invalid usage";
- $self->help ('history');
+ $self->help('history');
} # if
} elsif ($line =~ /^\s*savehist\s*(.*)/i) {
if ($1 =~ /(\S+)\s+(\d+)\s+(\d+)\s*$/) {
- $self->history ('save', $1, $2, $3);
+ $self->history('save', $1, $2, $3);
} else {
error 'Invalid usage';
- $self->help ('savehist');
+ $self->help('savehist');
} # if
} elsif ($line =~ /^\s*get\s*(.*)/i) {
if ($1 =~ (/^\$*(\S+)\s*$/)) {
- my $value = $self->_get ($1);
-
+ my $value = $self->_get($1);
+
if ($value) {
display "$1 = $value";
} else {
} # if
} else {
error 'Invalid usage';
- $self->help ('get');
+ $self->help('get');
} # if
} elsif ($line =~ /^\s*set\s*(.*)/i) {
if ($1 =~ /^\$*(\S+)\s*=\s*(.*)/) {
- $self->_set ($1, $2)
+ $self->_set($1, $2)
} else {
error 'Invalid usage';
- $self->help ('set');
+ $self->help('set');
} # if
} elsif ($line =~ /^\s*source\s+(\S+)/i) {
- $result = $self->source ($1);
+ $result = $self->source($1);
} elsif ($line =~ /^\s*vars\s*/) {
- $self->vars ($line);
+ $self->vars($line);
} elsif ($line =~ /^\s*color\s*(.*)/i) {
if ($1 =~ /(1|on)/i) {
$opts{color} = 1;
if $ENV{ANSI_COLORS_DISABLED};
} elsif ($1 =~ /(0|off)/i) {
$opts{trace} = 0;
- $ENV{ANSI_COLORS_DISABLED} = 1;
+ local $ENV{ANSI_COLORS_DISABLED} = 1;
} elsif ($1 =~ /\s*$/) {
if ($ENV{ANSI_COLORS_DISABLED}) {
display 'Color is currently off';
} # if
} else {
error 'Invalid usage';
- $self->help ('color');
+ $self->help('color');
} # if
} elsif ($line =~ /^\s*trace\s*(.*)/i) {
if ($1 =~ /(1|on)/i) {
} # if
} else {
error 'Invalid usage';
- $self->help ('trace');
+ $self->help('trace');
} # if
} # if
} # if
return ($cmd, $line, $result);
} # _builtinCmds
-sub _interrupt () {
+sub _interrupt() {
# Announce that we have hit an interrupt
print color ('yellow') . "<Control-C>\n" . color ('reset');
return;
} # _interrupt
-sub _displayMatches ($$$) {
+sub _displayMatches($$$) {
my ($matches, $numMatches, $maxLength) = @_;
-
+
# Work on a copy... (Otherwise we were getting "Attempt to free unreferenced
# scalar" internal errors from perl)
my @Matches;
return;
} # _displayMatches
-
-sub new (;$$%) {
+
+sub new(;$$%) {
my ($class, $histfile, $eval, %cmds) = @_;
=pod
=cut
- my $self = bless {
- histfile => $histfile,
- }, $class;
-
my $me = get_me;
$histfile ||= "$ENV{HOME}/.${me}_hist";
+ my $self = bless {
+ histfile => $histfile,
+ }, $class;
+
error "Creating bogus .${me}_hist file!"
if $me eq '-' or $me eq '';
$self->{prompt} = "$me:";
# Set commands
- $self->set_cmds (%cmds);
+ $self->set_cmds(%cmds);
# Set some ornamentation
$_cmdline->ornaments ('s,e,u,') unless $Config{cppflags} =~ /win32/i;
# Read in history
- $self->set_histfile ($histfile);
+ $self->set_histfile($histfile);
# Generator function for completion matches
$_attribs = $_cmdline->Attribs;
# The following functionality requires Term::ReadLine::Gnu
if ($_haveGnu) {
# Bind a key to display completion
- $_cmdline->add_defun ('help-on-command', \&CmdLine::_gethelp, ord ("\cl"));
+ $_cmdline->add_defun('help-on-command', \&CmdLine::_gethelp, ord ("\cl"));
# Save a handy copy of RL_PROMPT_[START|END]_IGNORE
$self->{ignstart} = $_cmdline->RL_PROMPT_START_IGNORE;
if ($Config{cppflags} =~ /win32/i) {
$opts{trace} = 0;
- $ENV{ANSI_COLORS_DISABLED} = 1;
+ local $ENV{ANSI_COLORS_DISABLED} = 1;
} # if
return $self;
} # new
-sub get () {
+sub get() {
my ($self) = @_;
=pod
POSIX::sigaction (&POSIX::SIGINT, $oldaction);
} # if
- $line = $self->_interpolate ($line)
+ $line = $self->_interpolate($line)
if $line;
- $self->{cmdnbr}++
- unless $self->{sourcing};
+ $self->{cmdnbr}++ unless $self->{sourcing};
- ($cmd, $line, $result) = $self->_builtinCmds ($line);
+ ($cmd, $line, $result) = $self->_builtinCmds($line);
- $line = ''
- unless $cmd;
+ $line = '' unless $cmd;
} while ($cmd and $builtin_cmds{$cmd});
return ($line, $result);
} # get
-sub set_cmds (%) {
+sub set_cmds(%) {
my ($self, %cmds) = @_;
=pod
return;
} # set_cmds
-sub set_prompt ($) {
+sub set_prompt($) {
my ($self, $prompt) = @_;
=pod
return $return;
} # set_prompt
-sub set_histfile ($) {
+sub set_histfile($) {
my ($self, $histfile) = @_;
=pod
} # if
# Determine the number of lines in the history file
- open my $hist, '<', $histfile;
+ open my $hist, '<', $histfile
+ or croak "Unable to open history file $histfile";
# Set cmdnbr
for (<$hist>) {}
return;
} # set_histfile
-sub set_eval (;\&) {
+sub set_eval(;\&) {
my ($self, $eval) = @_;
=pod
return $returnEval;
} # set_eval
-sub help (;$) {
- my ($self, $cmd) = @_;
+sub help(;$$) {
+ my ($self, $cmd, $builtins) = @_;
=pod
my @help;
+ $builtins ||= 0;
+
$cmd ||= '';
$cmd =~ s/^\s+//;
$cmd =~ s/\s+$//;
if (/$searchStr/i) {
$helpFound = 1;
- my $cmdcolor = $builtin_cmds{$_} ? color ('cyan') : color ('magenta');
- my $boldOn = $builtin_cmds{$_} ? color ('white on_cyan') : color ('white on_magenta');
- my $boldOff = color ('reset') . $cmdcolor;
+ my $cmdcolor = $builtin_cmds{$_} ? color('cyan') : color('magenta');
- $cmd = "$cmdcolor$_";
- $cmd =~ s/($searchStr)/$boldOn$1$boldOff/g;
- $cmd .= " $_cmds{$_}{parms}" if $_cmds{$_}{parms};
- $cmd .= color ('reset');
- $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
+ $cmd = "$cmdcolor$_";
+ $cmd .= " $_cmds{$_}{parms}" if $_cmds{$_}{parms};
+ $cmd .= color('reset');
+ $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
push @help, $cmd;
} # if
} else {
for (sort keys %_cmds) {
+ next if $builtin_cmds{$_} and not $builtins;
+
my $cmdcolor = $builtin_cmds{$_} ? color ('cyan') : color ('magenta');
my $cmd = "$cmdcolor$_";
} # for
} # if
- $self->handleOutput ($cmd, @help);
+ $self->handleOutput($cmd, @help);
return;
} # help
-sub history (;$) {
+sub history(;$) {
my ($self, $action) = @_;
=pod
$_cmdline->add_history ($line);
display $line;
- my ($cmd, $result) = $self->_builtinCmds ($line);
+ my ($cmd, $result) = $self->_builtinCmds($line);
if ($builtin_cmds{$cmd}) {
return;
return;
} # history
-sub _get ($$) {
+sub _get($$) {
my ($self, $name) = @_;
=pod
return $self->{vars}{$name}
} # _get
-sub _set ($$) {
+sub _set($$) {
my ($self, $name, $value) = @_;
=pod
my $returnValue = $self->{vars}{$name};
if (defined $value) {
- $value = $self->_interpolate ($value);
+ $value = $self->_interpolate($value);
# Do not call eval if we are setting result - otherwise we recurse
# infinitely.
unless ($name eq 'result') {
no strict;
- $value = $self->{eval} ($value)
- if $self->{eval};
+ $value = $self->{eval}($value) if $self->{eval};
use strict;
} # unless
return $returnValue;
} # _set
-sub vars ($) {
+sub vars($) {
my ($self, $cmd) = @_;
=pod
push @output, "$_ = $self->{vars}{$_}"
for (keys %{$self->{vars}});
- $self->handleOutput ($cmd, @output);
+ $self->handleOutput($cmd, @output);
+
+ return;
} # vars
-sub handleOutput ($@) {
+sub handleOutput($@) {
my ($self, $line, @output) = @_;
=pod
return;
} # handleOutput
-sub source ($) {
+sub source($) {
my ($self, $file) = @_;
=pod
next if $builtin_cmds{$cmd};
no strict;
- $result = $self->{eval} ($line);
+ $result = $self->{eval}($line);
use strict;
if (defined $result) {
sub DESTROY {
my ($self) = @_;
- $_cmdline->WriteHistory ($self->{histfile})
+ $_cmdline->WriteHistory($self->{histfile})
if $_cmdline and $_haveGnu;
return;
my $SECS_IN_DAY = $SECS_IN_HOUR * 24;
# Forwards
-sub Today2SQLDatetime ();
-sub DateToEpoch ($);
-sub EpochToDate ($);
+sub Today2SQLDatetime();
+sub DateToEpoch($);
+sub EpochToDate($);
-sub ymdhms {
+sub ymdhms(;$) {
my ($time) = @_;
$time ||= time;
return $year, $mon, $mday, $hour, $min, $sec;
} # ymdhms
-sub julian ($$$) {
+sub julian($$$) {
my ($year, $month, $day) = @_;
my $days = 0;
my $m = 1;
- foreach (@months) {
+ for (@months) {
last if $m >= $month;
$m++;
$days += $_;
- } # foreach
+ } # for
return $days + $day;
} # julian
-sub _is_leap_year ($) {
+sub _is_leap_year($) {
my ($year) = @_;
-
+
return 0 if $year % 4;
return 1 if $year % 100;
return 0 if $year % 400;
-
+
return 1;
} # _is_leap_year
-sub Add ($%) {
+sub Add($%) {
my ($datetime, %parms) = @_;
-
+
=pod
=head2 Add ($datetime, %parms)
'days',
'months',
);
-
- foreach (keys %parms) {
+
+ for (keys %parms) {
unless (InArray ($_, @validKeys)) {
croak "Invalid key in DateUtils::Add: $_";
} # unless
- } # foreach
-
+ } # for
+
my $epochTime = DateToEpoch $datetime;
-
+
my $amount = 0;
-
+
$parms{seconds} ||= 0;
$parms{minutes} ||= 0;
$parms{hours} ||= 0;
$parms{days} ||= 0;
-
+
$amount += $parms{days} * $SECS_IN_DAY;
$amount += $parms{hours} * $SECS_IN_HOUR;
$amount += $parms{minutes} * $SECS_IN_MIN;
$amount += $parms{seconds};
-
+
$epochTime += $amount;
$datetime = EpochToDate $epochTime;
-
+
if ($parms{month}) {
my $years = $parms{month} / 12;
my $months = $parms{month} % 12;
-
+
my $month = substr $datetime, 5, 2;
-
+
$years += ($month + $months) / 12;
substr ($datetime, 5, 2) = ($month + $months) % 12;
-
+
substr ($datetime, 0, 4) = substr ($datetime, 0, 4) + $years;
} # if
-
+
return $datetime;
} # Add
-sub Age ($) {
+sub Age($) {
my ($timestamp) = @_;
=pod
my $leap_days = 0;
for (my $i = $timestamp_year; $i < $today_year; $i++) {
-
$leap_days++ if $i % 4 == 0;
} # for
} # if
} # Age
-sub Compare ($$) {
+sub Compare($$) {
my ($date1, $date2) = @_;
-
+
=pod
-=head2 Compare ($date2, $date2)
+=head2 Compare ($date1, $date2)
Compares two datetimes returning -1 if $date1 < $date2, 0 if equal or 1 if
$date1 > $date2
return DateToEpoch ($date1) <=> DateToEpoch ($date2);
} # Compare
-sub DateToEpoch ($) {
+sub DateToEpoch($) {
my ($date) = @_;
-
+
=pod
=head2 DateToEpoch ($datetime)
my $hour = substr $date, 11, 2;
my $minute = substr $date, 14, 2;
my $seconds = substr $date, 17, 2;
-
+
my $days;
for (my $i = 1970; $i < $year; $i++) {
$days += _is_leap_year ($i) ? 366 : 365;
} # for
-
+
my @monthDays = (
0,
31,
304,
334,
);
-
+
$days += $monthDays[$month - 1];
-
- $days++
- if _is_leap_year ($year) and $month > 2;
-
- $days += $day - 1;
-
+
+ $days++ if _is_leap_year ($year) and $month > 2;
+
+ $days += $day - 1;
+
return ($days * $SECS_IN_DAY)
+ ($hour * $SECS_IN_HOUR)
+ ($minute * $SECS_IN_MIN)
+ $seconds;
} # DateToEpoch
-sub EpochToDate ($) {
+sub EpochToDate($) {
my ($epoch) = @_;
-
+
=pod
=head2 EpochToDate ($epoch)
=cut
- my $year = 1970;
my ($month, $day, $hour, $minute, $seconds);
+
+ my $year = 1970;
my $leapYearSecs = 366 * $SECS_IN_DAY;
my $yearSecs = $leapYearSecs - $SECS_IN_DAY;
-
+
while () {
my $amount = _is_leap_year ($year) ? $leapYearSecs : $yearSecs;
-
- last
- if $amount > $epoch;
-
+
+ last if $amount > $epoch;
+
$epoch -= $amount;
$year++;
} # while
-
+
my $leapYearAdjustment = _is_leap_year ($year) ? 1 : 0;
-
+
if ($epoch >= (334 + $leapYearAdjustment) * $SECS_IN_DAY) {
$month = '12';
$epoch -= (334 + $leapYearAdjustment) * $SECS_IN_DAY;
$epoch = $epoch % $SECS_IN_HOUR;
$minute = int ($epoch / $SECS_IN_MIN);
$seconds = $epoch % $SECS_IN_MIN;
-
+
$day = "0$day" if $day < 10;
$hour = "0$hour" if $hour < 10;
$minute = "0$minute" if $minute < 10;
$seconds = "0$seconds" if $seconds < 10;
-
+
return "$year-$month-$day $hour:$minute:$seconds";
} # EpochToDate
-sub UTCTime ($) {
+sub UTCTime($) {
my ($datetime) = @_;
-
+
=pod
=head2 UTCTime ($epoch)
my ($sec, $min, $hour, $mday, $mon, $year) = gmtime (
DateToEpoch ($datetime) - (timegm (@localtime) - timelocal (@localtime))
);
-
+
$year += 1900;
$mon++;
- $sec = '0' . $sec if $sec < 10;
- $min = '0' . $min if $min < 10;
- $hour = '0' . $hour if $hour < 10;
+ $sec = '0' . $sec if $sec < 10;
+ $min = '0' . $min if $min < 10;
+ $hour = '0' . $hour if $hour < 10;
$mon = '0' . $mon if $mon < 10;
$mday = '0' . $mday if $mday < 10;
-
+
return "$year-$mon-${mday}T$hour:$min:${sec}Z";
} # UTCTime
-sub UTC2Localtime ($) {
+sub UTC2Localtime($) {
my ($utcdatetime) = @_;
-
+
# If the field does not look like a UTC time then just return it.
return $utcdatetime unless $utcdatetime =~ /\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2}Z/;
my @localtime = localtime;
- return EpochToDate (
+ return EpochToDate(
DateToEpoch ($utcdatetime) + (timegm (@localtime) - timelocal (@localtime))
);
} # UTC2Localtime
-sub FormatDate ($) {
- my ($date) = @_;
+sub FormatDate($;$) {
+ my ($date, $separator) = @_;
=pod
-=head2 FormatDate ($date)
+=head2 FormatDate ($date, $separator)
Formats date
Date in YYYYMMDD
+=tiem $separator
+
+If specified, indicates that $date has separators (e.g. 2021-07-04).
+
=back
=for html </blockquote>
=cut
- return substr ($date, 4, 2)
- . "/"
- . substr ($date, 6, 2)
- . "/"
- . substr ($date, 0, 4);
+ unless ($separator) {
+ return substr($date, 4, 2) . '/'
+ . substr($date, 6, 2) . '/'
+ . substr($date, 0, 4);
+ } else {
+ return substr($date, 5, 2)
+ . '/'
+ . substr($date, 8, 2)
+ . '/'
+ . substr($date, 0, 4);
+ } # if
} # FormatDate
-sub FormatTime ($) {
+sub FormatTime($) {
my ($time) = @_;
=pod
my $AmPm = $hours > 12 ? "Pm" : "Am";
$hours = $hours - 12 if $hours > 12;
-
+
$hours = "0$hours" if length $hours == 1;
return "$hours:$minutes $AmPm";
} # FormatTime
-sub MDY (;$) {
+sub MDY(;$) {
my ($time) = @_;
=pod
return "$mon/$mday/$year";
} # MDY
-sub SQLDatetime2UnixDatetime ($) {
+sub SQLDatetime2UnixDatetime($) {
my ($sqldatetime) = @_;
=pod
return $months{$month} . " $day, $year \@ $time";
} # SQLDatetime2UnixDatetime
-sub SubtractDays ($$) {
+sub SubtractDays($$) {
my ($timestamp, $nbr_of_days) = @_;
=pod
my $month = substr $timestamp, 5, 2;
my $day = substr $timestamp, 8, 2;
+ # We are not properly accounting for leap days but this is just a rough
+ # estimate anyway
+ if ($nbr_of_days > 365) {
+ $year -= int $nbr_of_days / 365;
+
+ $nbr_of_days = $nbr_of_days % 365;
+ } # if
+
# Convert to Julian
my $days = julian $year, $month, $day;
return $year . "-" . $month . "-" . $days . substr $timestamp, 10;
} # SubtractDays
-sub Today2SQLDatetime () {
+sub Today2SQLDatetime() {
=pod
=cut
- return UnixDatetime2SQLDatetime (scalar (localtime));
+ return UnixDatetime2SQLDatetime(scalar localtime);
} # Today2SQLDatetime
-sub UnixDatetime2SQLDatetime ($) {
+sub UnixDatetime2SQLDatetime($) {
my ($datetime) = @_;
=pod
unless ($months{$month_name}) {
$month_name = substr $datetime, 8, 3;
} # unless
-
+
my $month = $months{$month_name};
my $time = substr $datetime, 11, 8;
warning "Year undefined for $orig_datetime\nReturning today's date";
return Today2SQLDatetime;
} # unless
-
+
unless ($month) {
warning "Month undefined for $orig_datetime\nReturning today's date";
return Today2SQLDatetime;
} # unless
-
+
unless ($day) {
warning "Day undefined for $orig_datetime\nReturning today's date";
return Today2SQLDatetime;
return "$year-$month-$day $time";
} # UnixDatetime2SQLDatetime
-sub YMD (;$) {
+sub YMD(;$) {
my ($time) = @_;
=pod
return "$year$mon$mday";
} # YMD
-sub YMDHM (;$) {
+sub YMDHM(;$) {
my ($time) = @_;
=pod
return "$year$mon$mday\@$hour:$min";
} # YMDHM
-sub YMDHMS (;$) {
+sub YMDHMS(;$) {
my ($time) = @_;
=pod
return "$year$mon$mday\@$hour:$min:$sec";
} # YMDHMS
-sub timestamp (;$) {
+sub timestamp(;$) {
my ($time) = @_;
=pod
--- /dev/null
+=pod
+
+=head1 NAME $RCSfile: MyDB.pm,v $
+
+Object oriented, quick and easy interface to MySQL/MariaDB databases
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@DeFaria.com>
+
+=item Revision
+
+$Revision: 1.0 $
+
+=item Created
+
+Sat 19 Jun 2021 11:05:00 PDT
+
+=item Modified
+
+$Date: $
+
+=back
+
+=head1 SYNOPSIS
+
+Provides lower level, basic database routines in an Perl object
+
+ # Instanciate MyDB object
+ my $db = MyDB->new(<database>, <username>, <password>, %opts);
+
+ # Add record
+ my $status = $db->add(<tablename>, <%record>);
+
+ # Delete record
+ my $status = $db->delete(<tablename>, <condition>);
+
+ # Modify record
+ my $status = $db->modify(<tablename>, <%record>, <condition>)
+
+ # Get records
+ my @records = $db->get(<tablename>, <condition>, <fields>, <additional>)
+
+=head1 DESCRIPTION
+
+Low level but convienent database routines
+
+=head1 ROUTINES
+
+The following routines are exported:
+
+=cut
+
+package MyDB;
+
+use strict;
+use warnings;
+
+use Carp;
+use DBI;
+use Exporter;
+
+use Utils;
+
+# Globals
+our $VERSION = '$Revision: 1.0 $';
+ ($VERSION) = ($VERSION =~ /\$Revision: (.*) /);
+
+my %opts = (
+ MYDB_USERNAME => $ENV{MYDB_USERNAME},
+ MYDB_PASSWORD => $ENV{MYDB_PASSWORD},
+ MYDB_DATABASE => $ENV{MYDB_DATABASE},
+ MYDB_SERVER => $ENV{MYDB_SERVER} || 'localhost',
+);
+
+# Internal methods
+sub _dberror($$) {
+ my ($self, $msg, $statement) = @_;
+
+ my $dberr = $self->{db}->err;
+ my $dberrmsg = $self->{db}->errstr;
+
+ $dberr ||= 0;
+ $dberrmsg ||= 'Success';
+
+ my $message = '';
+
+ if ($dberr) {
+ my $function = (caller(1)) [3];
+
+ $message = "$function: $msg\nError #$dberr: $dberrmsg\n"
+ . "SQL Statement: $statement";
+ } # if
+
+ return $dberr, $message;
+} # _dberror
+
+sub _encode_decode ($$$) {
+ my ($self, $type, $password, $userid) = @_;
+
+ my $statement = 'select ';
+
+ if ($type eq 'encode') {
+ $statement .= "hex(aes_encrypt('$password','$userid'))";
+ } elsif ($type eq 'decode') {
+ $statement .= "aes_decrypt(unhex('$password'),'$userid')";
+ } # if
+
+ my $sth = $self->{db}->prepare($statement)
+ or return $self->_dberror('MyDB::$type: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or $self->_dberror('MyDB::$type: Unable to execute statement', $statement);
+
+ my @row = $sth->fetchrow_array;
+
+ return $row[0];
+} # _encode_decode
+
+sub _formatValues(@) {
+ my ($self, @values) = @_;
+
+ my @returnValues;
+
+ # Quote data values
+ push @returnValues, ($_ and $_ ne '')
+ ? $self->{db}->quote($_)
+ : 'null'
+ for (@values);
+
+ return @returnValues;
+} # _formatValues
+
+sub _formatNameValues(%) {
+ my ($self, %rec) = @_;
+
+ my @nameValueStrs;
+
+ for (keys %rec) {
+ if ($rec{$_}) {
+ push @nameValueStrs, "$_=" . $self->{db}->quote($rec{$_});
+ } else {
+ push @nameValueStrs, "$_=null";
+ } # if
+ } # for
+
+ return @nameValueStrs;
+} # _formatNameValues
+
+sub add($%) {
+ my ($self, $table, %rec) = @_;
+
+ my $statement = "insert into $table (";
+ $statement .= join ',', keys %rec;
+ $statement .= ') values (';
+ $statement .= join ',', $self->_formatValues(values %rec);
+ $statement .= ')';
+
+ $self->{db}->do($statement);
+
+ return $self->_dberror("Unable to add record to $table", $statement);
+} # add
+
+sub check($) {
+ my ($self, $table) = @_;
+
+ my @tables;
+
+ if (ref $table eq 'ARRAY') {
+ @tables = @$table;
+ } else {
+ push @tables, $table;
+ } # if
+
+ my $statement = 'check table ';
+ $statement .= join ',', @tables;
+
+ $self->{db}->do($statement);
+
+ return $self->_dberror('MyDB::check: Unable to check tables', $statement);
+} # check
+
+sub count($;$) {
+ my ($self, $table, $condition) = @_;
+
+ my $statement = "select count(*) from $table";
+ $statement .= " where $condition" if $condition;
+
+ my $sth = $self->{db}->prepare($statement)
+ or return $self->_dberror('MyDB::count: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or return $self->_dberror('MyDB::count: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many entries there are
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ my $count;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ wantarray ? return (0, 'No records found') : return 0;
+ } else {
+ wantarray ? return ($row[0], 'Records found') : return $row[0];
+ } # unless
+
+ return;
+} # count
+
+sub count_distinct($$;$) {
+ my ($self, $table, $column, $condition) = @_;
+
+ my $statement = "select count(distinct $column) from $table";
+ $statement .= " where $condition" if $condition;
+
+ my $sth = $self->{db}->prepare($statement)
+ or return $self->_dberror('MyDB::count: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or return $self->_dberror('MyDB::count: Unable to execute statement', $statement);
+
+ # Get return value, which should be how many entries there are
+ my @row = $sth->fetchrow_array;
+
+ # Done with $sth
+ $sth->finish;
+
+ my $count;
+
+ # Retrieve returned value
+ unless ($row[0]) {
+ wantarray ? return (0, 'No records found') : return 0;
+ } else {
+ wantarray ? return ($row[0], 'Records found') : return $row[0];
+ } # unless
+
+ return;
+} # count_distinct
+
+sub decode($$) {
+ my ($self, $password, $userid) = @_;
+
+ return $self->_encode_decode('decode', $password, $userid);
+} # decode
+
+sub delete($;$) {
+ my ($self, $table, $condition) = @_;
+
+ my $count = $self->count($table, $condition);
+
+ return ($count, 'Records deleted') if $count == 0;
+
+ my $statement = "delete from $table ";
+ $statement .= "where $condition" if $condition;
+
+ $self->{db}->do($statement);
+
+ if ($self->{db}->err) {
+ my ($err, $msg) = $self->_dberror("MyDB::delete: Unable to delete record(s) from $table", $statement);
+
+ wantarray ? return (-$err, $msg) : return -$err;
+ } else {
+ wantarray ? return ($count, 'Records deleted') : return $count;
+ } # if
+
+ return;
+} # delete
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $self->{db}->disconnect if $self->{db};
+
+ return;
+} # DESTROY
+
+sub encode($$) {
+ my ($self, $password, $userid) = @_;
+
+ return $self->_encode_decode('encode', $password, $userid);
+} # encode
+
+sub find($;$@) {
+ my ($self, $table, $condition, $fields, $additional) = @_;
+
+ $fields //= '*';
+
+ $fields = join ',', @$fields if ref $fields eq 'ARRAY';
+
+ my $statement = "select $fields from $table";
+ $statement .= " where $condition" if $condition;
+ $statement .= " $additional" if $additional;
+
+ $self->{sth} = $self->{db}->prepare($statement)
+ or return $self->_dberror('MyDB::find: Unable to prepare statement', $statement);
+
+ $self->{sth}->execute
+ or return $self->_dberror('MyDB::find: Unable to execute statement', $statement);
+
+ return $self->_dberror("MyDB::find: Unable to find record ($table, $condition)", $statement);
+} # find
+
+sub get($;$$$) {
+ my ($self, $table, $condition, $fields, $additional) = @_;
+
+ $fields //= '*';
+
+ $fields = join ',', @$fields if ref $fields eq 'ARRAY';
+
+ my $statement = "select $fields from $table";
+ $statement .= " where $condition" if $condition;
+ $statement .= " $additional" if $additional;
+
+ my $rows = $self->{db}->selectall_arrayref($statement, { Slice => {} });
+
+ return $rows if $rows;
+ return $self->_dberror('MyDB::get: Unable to prepare/execute statement', $statement);
+} # get
+
+sub getone($;$$$) {
+ my ($self, $table, $condition, $fields, $additional) = @_;
+
+ my $rows = $self->get($table, $condition, $fields, $additional);
+
+ return $rows->[0];
+} # getone
+
+sub getnext() {
+ my ($self) = @_;
+
+ return unless $self->{sth};
+
+ return $self->{sth}->fetchrow_hashref;
+} # getnext
+
+sub lastid() {
+ my ($self) = @_;
+
+ my $statement = 'select last_insert_id()';
+
+ my $sth = $self->{db}->prepare($statement)
+ or $self->_dberror('MyDB::lastid: Unable to prepare statement', $statement);
+
+ $sth->execute
+ or $self->_dberror('MyDB::lastid: Unable to execute statement', $statement);
+
+ my @row = $sth->fetchrow_array;
+
+ return $row[0];
+} # lastid
+
+sub lock(;$$) {
+ my ($self, $type, $table) = @_;
+
+ $type //= 'read';
+
+ croak "Type must be read or write" unless $type =~ /(read|write)/;
+
+ my $tables;
+
+ if (ref $table eq 'ARRAY') {
+ $tables = join " $type,", @$table;
+ } else {
+ $tables = $table;
+ } # if
+
+ my $statement = "lock tables $tables";
+ $statement .= " $type";
+
+ $self->{db}->do($statement);
+
+ return $self->_dberror("MyDB::lock Unable to lock $tables", $statement);
+} # lock
+
+sub modify($$%) {
+ my ($self, $table, $condition, %rec) = @_;
+
+ my $statement = "update $table set ";
+ $statement .= join ',', $self->_formatNameValues(%rec);
+ $statement .= " where $condition" if $condition;
+
+ $self->{db}->do($statement);
+
+ return $self->_dberror("MyDB::modify: Unable to update record in $table", $statement);
+} # modify
+
+sub new(;$$$$) {
+ my ($class, $username, $password, $database, $dbserver) = @_;
+
+ my $self = {
+ username => $username || $opts{MYDB_USERNAME},
+ password => $password || $opts{MYDB_PASSWORD},
+ database => $database || $opts{MYDB_DATABASE},
+ dbserver => $dbserver || $opts{MYDB_SERVER},
+ };
+
+ bless $self, $class;
+
+ $self->{dbdriver} = 'mysql';
+
+ $self->{db} = DBI->connect(
+ "DBI:$self->{dbdriver}:$database:$self->{dbserver}",
+ $self->{username},
+ $self->{password},
+ {PrintError => 0},
+ ) or croak "MyDB::new: Couldn't connect to $database database as $self->{username}\@$self->{dbserver}";
+
+ return $self;
+} # new
+
+sub optimize($) {
+ my ($self, $table) = @_;
+
+ my @tables;
+
+ if (ref $table eq 'ARRAY') {
+ @tables = @$table;
+ } else {
+ push @tables, $table;
+ } # if
+
+ my $statement = 'optimize table ';
+ $statement .= join ',', @tables;
+
+ $self->{db}->do($statement);
+
+ return $self->_dberror('MyDB::optimize: Unable to optimize tables', $statement);
+} # optimize
+
+sub unlock() {
+ my ($self) = @_;
+
+ my $statement = 'unlock tables';
+
+ $self->{db}->do($statement);
+
+ return $self->_dberror('MyDB::unlock: Unable to unlock tables', $statement);
+} # unlock
+
+sub update($$%) {
+ # Using a Perl goto statement in this fashion really just creates an alias
+ # such that the user can call either modify or update.
+ goto &modify;
+} # update
+
+1;
use OSDep;
use Display;
+our $pipe;
+
our @EXPORT = qw (
+ CheckParms
EnterDaemonMode
Execute
GetChildren
Usage
);
-sub _restoreTerm () {
+sub _restoreTerm() {
# In case the user hits Ctrl-C
print "\nControl-C\n";
exit;
} # _restoreTerm
-sub EnterDaemonMode (;$$$) {
+sub CheckParms($$) {
+ my ($requiredFields, $rec) = @_;
+
+ my $msg = RequiredFields($requiredFields, $rec);
+
+ my $function = (caller(1))[3];
+
+ croak "Internal error: $function: $msg" if $msg;
+
+ return;
+} # CheckParms
+
+sub EnterDaemonMode(;$$$) {
my ($logfile, $errorlog, $pidfile) = @_;
=pod
return;
} # EnterDaemonMode
-sub Execute ($) {
+sub Execute($) {
my ($cmd) = @_;
=pod
chomp @output;
- return ($status, @output);
+ wantarray ? return ($status, @output) : $status;
} # Execute
-sub GetChildren (;$) {
+sub GetChildren(;$) {
my ($pid) = @_;
=pod
chomp @output;
- foreach (@output) {
+ for (@output) {
# Skip the pstree process and the parent process - we want only
# our children.
next if /pstree/ or /\($pid\)/;
if (/\((\d+)\)/) {
push @children, $1;
} # if
- } # foreach
+ } # for
return @children;
} # GetChildren
-sub GetPassword (;$) {
+sub GetPassword(;$) {
my ($prompt) = @_;
=pod
return $password;
} # GetPassword
-sub InArray ($@) {
+sub InArray($@) {
my ($item, @array) = @_;
=pod
=cut
- foreach (@array) {
+ for (@array) {
return $TRUE if $item eq $_;
- } # foreach
+ } # for
return $FALSE;
} # InArray
=for html </blockquote>
-=cut
-
+=cut
# TODO: Make it work on Windows...
return if $^O =~ /win/i;
}
} # LoadAvg
-our $pipe;
-
-sub StartPipe ($;$) {
+sub StartPipe($;$) {
my ($to, $existingPipe) = @_;
=pod
} # if
} # StartPipe
-sub PipeOutputArray ($@) {
+sub PipeOutputArray($@) {
my ($to, @output) = @_;
=pod
=item $to
String representing the other end of the pipe to pipe @output to
-
+
=item @output
Output to pipe
=cut
- open my $pipe, '|', $to
+ open my $pipe, '|-', $to
or error "Unable to open pipe - $!", 1;
- foreach (@output) {
+ for (@output) {
chomp;
print $pipe "$_\n";
- } # foreach
+ } # for
return close $pipe;
} # PipeOutputArray
-sub PipeOutput ($;$) {
+sub PipeOutput($;$) {
my ($line, $topipe) = @_;
=pod
return;
} # PipeOutput
-sub StopPipe (;$) {
+sub StopPipe(;$) {
my ($pipeToStop) = @_;
=pod
return;
} # StopPipe
-sub PageOutput (@) {
+sub PageOutput(@) {
my (@output) = @_;
-
+
=pod
=head2 PageOutput (@ouput)
PipeOutputArray $ENV{PAGER}, @output;
} else {
print "$_\n"
- foreach (@output);
+ for (@output);
} # if
-
+
return;
} # PageOutput
-sub RedirectOutput ($$@) {
+sub RedirectOutput($$@) {
my ($to, $mode, @output) = @_;
=pod
open my $out, $mode, $to
or croak "Unable to open $to for writing - $!";
- foreach (@output) {
+ for (@output) {
chomp;
print $out "$_\n";
- } # foreach
+ } # for
- return;
+ return;
} # RedirectOutput
-sub ReadFile ($) {
+sub ReadFile($) {
my ($filename) = @_;
=pod
my @cleansed_lines;
- foreach (@lines) {
+ for (@lines) {
chomp;
chop if /\r/;
push @cleansed_lines, $_ if !/^#/; # Discard comment lines
- } # foreach
+ } # for
return @cleansed_lines;
} else {
} # if
} # ReadFile
-sub Stats ($;$) {
+sub Stats($;$) {
my ($total, $log) = @_;
=pod
display $msg;
} # if
- foreach (sort keys %$total) {
+ for (sort keys %$total) {
$msg = $total->{$_} . "\t $_";
if ($log) {
} else {
display $msg;
} # if
- } # foreach
+ } # for
} # if
return;
} # Stats
-sub Usage (;$) {
+sub Usage(;$) {
my ($msg) = @_;
=pod
=cut
- display $msg
- if $msg;
+ display $msg if $msg;
system "perldoc $0";
////////////////////////////////////////////////////////////////////////////////
//
-// File: $RCSFile$
-// Revision: $Revision: 1.1 $
-// Description: This JavaScript performs some simple validations for the
-// actions buttons on the list page.
-// Author: Andrew@DeFaria.com
-// Created: Fri Nov 29 14:17:21 2002
-// Modified: $Date: 2013/06/12 14:05:47 $
-// Language: JavaScript
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: This JavaScript performs some simple validations for the
+// actions buttons on the list page.
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:47 $
+// Language: JavaScript
//
// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
//
var current_entry = "";
var current_entry_nbr = 0;
- var digits = /[^\d]+(\d+)/;
- var parmname = /([^\d]+)\d+/;
+ var digits = /[^\d]+(\d+)/;
+ var parmname = /([^\d]+)\d+/;
+ var retention = /\d+\s(day|days|week|weeks|month|months|year|years)$/i;
for (var i = 0; i < form.length; i++) {
var e = form.elements [i];
if (e.type == "text") {
var name = e.name;
- var parm = name.match (parmname);
- var nbr = name.match (digits);
+ var parm = name.match(parmname);
+ var nbr = name.match(digits);
if (current_entry_nbr == 0) {
- current_entry_nbr = nbr [1];
+ current_entry_nbr = nbr[1];
} // if
- if (nbr [1] == current_entry_nbr) {
- if (parm [1] == "pattern" || parm [1] == "domain") {
- current_entry = current_entry + e.value;
- } // if
+ if (nbr[1] == current_entry_nbr) {
+ if (parm[1] == "pattern" || parm[1] == "domain") {
+ current_entry = current_entry + e.value;
+ } // if
+ if (parm[1] == "retention") {
+ if (e.value != '' && e.value.match(retention) == null) {
+ alert("Retention must be specified in terms of days, weeks, months "
+ + "or years for entry #" + current_entry_nbr + ". Not \"" + e.value + "\"");
+ return false;
+ } // if
+ } // if
+ if (parm[1] == "hit_count") {
+ if (e.value == 0 || e.value == '' || parseInt(e.value)) {
+ // Do nothing
+ } else {
+ alert("Hit Count must be numeric for entry #" + current_entry_nbr);
+ return false;
+ } // if
+ } // if
} else {
- if (current_entry == "") {
- alert ("You must specify a value for Username and/or Domain for entry #" + current_entry_nbr);
- return false;
- } // if
- current_entry_nbr = nbr [1];
- current_entry = e.value;
+ if (current_entry == "") {
+ alert ("You must specify a value for Username and/or Domain for entry #" + current_entry_nbr);
+ return false;
+ } // if
+ current_entry_nbr = nbr[1];
+ current_entry = e.value;
} // if
} // if
} // for
+++ /dev/null
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
-<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">\r
-<head>\r
- <title>MAPS: Reports</title>\r
- <link rev="made" href="mailto:Andrew%40DeFaria.com">\r
- <link rel="stylesheet" type="text/css" href="/maps/css/MAPSStyle.css">\r
- <script src="/maps/JavaScript/CheckAddress.js" type="text/javascript"></script>\r
-</head>\r
-<body>\r
-<div class="heading">\r
-<h2 class="header" align="center"><font class="standout">MAPS</font>\r
-Reports</h2>\r
-<h2 class="header" align="center"></h2>\r
-</div>\r
-<div class="content">\r
-<div class="leftbar">\r
-<div class="username">Welcome Andrew</div>\r
-<div class="menu"><a href="/maps/">MAPS Home<br>\r
-</a> <a href="/maps/bin/stats.cgi">Statistics<br>\r
-</a> <a href="/maps/bin/editprofile.cgi">Edit Profile<br>\r
-</a> <a href="/maps/Reports.html">Reports<br>\r
-</a> <a href="/maps/ManageLists.html">Manage Lists</a><a\r
- href="/maps/Utilities.html"><br>\r
-</a> <a href="/maps/doc/">Help<br>\r
-</a> <a href="/maps/adm/">MAPS Admin<br>\r
-</a> <a href="/maps/?logout=yes">Logout</a></div>\r
-</div>\r
-<h2>Reports</h2>\r
-<ul>\r
- <li>Returned messages by domain</li>\r
- <li>Recent Activity<br>\r
- </li>\r
- <li>Space Usage</li>\r
-</ul>\r
-<br>\r
-<div class="copyright">Copyright © 2001-2003 - All rights reserved<br>\r
-<a href="https://defaria.com">Andrew DeFaria</a> <a\r
- href="mailto:Andrew@DeFaria.com"><Andrew@DeFaria.com></a></div>\r
-</div>\r
-</body>\r
-</html>\r
<body onResize="AdjustTableWidth ("signup");">
<div class="heading">
-<h2 class="header" align="center"><font class="standout">MAPS</font>
-Spam Elimination System</h2>
+<h2 class="header" align="center">Spam Elimination System</h2>
<h3 class="header" align="center">Sign up for MAPS</h3>
</div>
<head>\r
<title>MAPS: Administration</title>\r
<link rev="made" href="mailto:Andrew%40DeFaria.com">\r
- <link rel="stylesheet" type="text/css" href="maps.css">\r
+ <link rel="stylesheet" type="text/css" href="/maps/css/MAPSStyle.css">\r
<script src="CheckAddress.js" type="text/javascript"></script>\r
</head>\r
<body>\r
<div class="heading">\r
-<h2 class="header" align="center"><font class="standout">MAPS</font>\r
-Administration</h2>\r
+<h2 class="header" align="center">Administration</h2>\r
</div>\r
<div class="content">\r
<div class="leftbar">\r
key sender_index (sender)
); -- email
--- whitelist: Table holds the users' whitelists
+-- list: Table holds the users' various lists
create table list (
userid varchar (128) not null,
type enum ("white", "black", "null") not null,
sequence smallint,
hit_count integer,
last_hit datetime,
+
+-- Retention: This field indicates how much time must pass before an inactive
+-- list entry should be scrubbed. Null indicates retain forever.
+-- other values include "x day(s)", "x month(s)", "x year(s)". So,
+-- for example, a user on the white list may have its retention set
+-- to say 1 year and when mapsscrub runs, if last_hit is older than
+-- a year the whitelist entry would be removed. If, however,
+-- retention is null then the record is kept forever. This is useful
+-- for the null and black lists where one might want to insure that
+-- a particular domain (e.g. @talentburst.com) will never come off
+-- of the nulllist.
+-- retention varchar (40),
key user_index (userid),
key user_listtype (userid, type),
unique (userid, type, sequence),
-- Create users
-- New 8.0 syntax...
-create user 'maps'@'localhost' identified by 'spam';
+--create user 'maps'@'localhost' identified by 'spam';
grant all privileges on MAPS.* to 'maps'@'localhost';
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
+use Utils;
+
use MAPS;
use MAPSLog;
use MAPSWeb;
-use MAPSUtil;
use CGI qw/:standard *table/;
use CGI::Carp 'fatalsToBrowser';
-my $userid;
-my $Userid;
-my $type = 'black';
+sub Add2List(%) {
+ my (%rec) = @_;
+
+ CheckParms(['userid', 'type'], \%rec);
-sub Add2List() {
- my $sender = '';
- my $nextseq = GetNextSequenceNo($userid, $type);
+ my $nextseq = GetNextSequenceNo(%rec);
+
+ my $Userid = ucfirst $rec{userid};
while () {
- my $pattern = param "pattern$nextseq";
- my $domain = param "domain$nextseq";
- my $comment = param "comment$nextseq";
+ $rec{pattern} = param "pattern$nextseq";
+ $rec{domain} = param "domain$nextseq";
+ $rec{comment} = param "comment$nextseq";
+ $rec{hit_count} = param "hit_count$nextseq";
+ $rec{retention} = param "retention$nextseq";
- last if ((!defined $pattern || $pattern eq '') &&
- (!defined $domain || $domain eq ''));
+ last unless $rec{pattern} or $rec{domain};
- $sender = CheckEmail $pattern, $domain;
+ $rec{sender} = CheckEmail $rec{pattern}, $rec{domain};
- my ($status, $rule) = OnBlacklist($sender);
+ my ($status, $rule) = OnBlacklist($rec{sender});
if ($status != 0) {
- print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
+ print br {-class => 'error'},
+ "The email address $rec{sender} is already on ${Userid}'s $rec{type} list";
} else {
- Add2Blacklist($sender, $userid, $comment);
- print br "The email address, $sender, has been added to ${Userid}'s $type list";
+ my ($messages, $msg) = Add2Blacklist(%rec);
+
+ if ($messages < -1) {
+ print br {-class => 'error'}, "Unable to add $rec{sender} to $rec{type} list";
+ return;
+ } else {
+ print br "The email address, $rec{sender}, has been added to ${Userid}'s $rec{type} list";
+ } # if
# Now remove this entry from the other lists (if present)
for my $otherlist ('white', 'null') {
- my $sth = FindList $otherlist, $sender;
- my ($sequence, $count);
+ FindList(
+ userid => $rec{userid},
+ type => $otherlist,
+ sender => $rec{sender},
+ );
+
+ my $seq = GetList;
- ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
+ if ($seq->{sequence}) {
+ my $err;
- if ($sequence) {
- $count = DeleteList($otherlist, $sequence);
- print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
- if $count > 0;
+ ($err, $msg) = DeleteList(
+ userid => $rec{userid},
+ type => $otherlist,
+ sequence => $seq->{sequence},
+ );
- ResequenceList($userid, $otherlist);
+ croak $msg if $err < 0;
+
+ print br "Removed $rec{sender} from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $err > 0;
+
+ ResequenceList(
+ userid => $rec{userid},
+ type => $otherlist,
+ );
} # if
} # for
} # if
$nextseq++;
} # while
+
+ return;
} # Add2List
# Main
-$userid = Heading(
+my $userid = Heading(
'getcookie',
'',
'Add to Black List',
'Add to Black List',
);
-$Userid = ucfirst $userid;
+$userid ||= $ENV{USER};
+
+my $type = 'black';
SetContext($userid);
NavigationBar($userid);
-Add2List;
+Add2List(
+ userid => $userid,
+ type => $type,
+);
print start_form {
- -method => 'post',
- -action => 'processaction.cgi',
- -name => 'list'
+ -method => 'post',
+ -action => 'processaction.cgi',
+ -name => 'list',
};
print '<p></p><center>',
- hidden ({-name => 'type',
- -default => $type}),
- submit ({-name => 'action',
- -value => 'Add'}),
+ hidden ({-name => 'type', -default => $type}),
+ submit ({-name => 'action', -value => 'Add'}),
'</center>';
Footing;
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
+use Utils;
+
use MAPS;
use MAPSLog;
use MAPSWeb;
-use MAPSUtil;
use CGI qw/:standard *table/;
use CGI::Carp 'fatalsToBrowser';
-my $userid;
-my $Userid;
-my $type = 'null';
+sub Add2List(%) {
+ my (%rec) = @_;
-sub Add2List() {
- my $sender = '';
- my $nextseq = GetNextSequenceNo($userid, $type);
+ CheckParms(['userid', 'type'], \%rec);
+
+ my $nextseq = GetNextSequenceNo(%rec);
+
+ my $Userid = ucfirst $rec{userid};
while () {
- my $pattern = param "pattern$nextseq";
- my $domain = param "domain$nextseq";
- my $comment = param "comment$nextseq";
- my $hit_count = param "hit_count$nextseq";
+ $rec{pattern} = param "pattern$nextseq";
+ $rec{domain} = param "domain$nextseq";
+ $rec{comment} = param "comment$nextseq";
+ $rec{hit_count} = param "hit_count$nextseq";
+ $rec{retention} = param "retention$nextseq";
- last if ((!defined $pattern || $pattern eq '') &&
- (!defined $domain || $domain eq ''));
+ last unless $rec{pattern }or $rec{domain};
- $sender = CheckEmail $pattern, $domain;
+ $rec{sender} = CheckEmail $rec{pattern}, $rec{domain};
- my ($status, $rule) = OnNulllist($sender);
+ my ($status, $rule) = OnNulllist($rec{sender});
if ($status != 0) {
- print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
+ print br {-class => 'error'},
+ "The email address $rec{sender} is already on ${Userid}'s $rec{type} list";
} else {
- $hit_count ||= CountMsg($sender);
-
- Add2Nulllist($sender, $userid, $comment, $hit_count);
+ my ($messages, $msg) = Add2Nulllist(%rec);
- print br "The email address, $sender, has been added to ${Userid}'s $type list";
+ if ($messages < -1) {
+ print br {-class => 'error'}, "Unable to add $rec{sender} to $rec{type} list";
+ return;
+ } else {
+ print br "The email address, $rec{sender}, has been added to ${Userid}'s $rec{type} list";
+ } # if
# Now remove this entry from the other lists (if present)
for my $otherlist ('white', 'black') {
- my $sth = FindList $otherlist, $sender;
- my ($sequence, $count);
+ FindList(
+ userid => $rec{userid},
+ type => $otherlist,
+ sender => $rec{sender},
+ );
- ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
+ my $seq = GetList;
- if ($sequence) {
- $count = DeleteList($otherlist, $sequence);
+ if ($seq->{sequence}) {
+ my $err;
- print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
- if $count > 0;
+ ($err, $msg) = DeleteList(
+ userid => $rec{userid},
+ type => $otherlist,
+ sequence => $seq->{sequence},
+ );
- ResequenceList($userid, $otherlist);
+ croak $msg if $err < 0;
+
+ print br "Removed $rec{sender} from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $err > 0;
+
+ ResequenceList(
+ userid => $rec{userid},
+ type => $otherlist,
+ );
} # if
} # for
} # if
$nextseq++;
} # while
+
+ return;
} # Add2List
# Main
-$userid = Heading(
+my $userid = Heading(
'getcookie',
'',
'Add to Null List',
'Add to Null List',
);
+$userid ||= $ENV{USER};
+
SetContext($userid);
NavigationBar($userid);
-$Userid = ucfirst $userid;
+my $type = 'null';
-Add2List;
+Add2List(
+ userid => $userid,
+ type => $type,
+);
print start_form {
-method => 'post',
# Highly specialized!
my $userid = $ENV{USER};
my $Userid;
-my $type = "null";
+my $type = 'null';
+
+die "TODO: Test this script";
sub GetItems($) {
my ($filename) = @_;
$item{domain} = $address[1];
$item{comment} = $fields[1] ? $fields[1] : '';
$item{hit_count} = $fields[2] ? $fields[2] : 0;
+ $item{retention} = $fields[3];
push @items, \%item;
} # while
} # GetItems
sub Add2List(@) {
- my @items = @_;
+ my (@items) = @_;
+
+ my $item;
- my $sender = '';
- my $nextseq = GetNextSequenceNo($userid, $type);
+ my $item->{sequence} = GetNextSequenceNo(
+ userid => $userid,
+ type => $type,
+ );
- for (@items) {
- my %item = %{$_};
+ $item->{userid} = $userid;
+ $item->{type} = $type;
- my $pattern = $item{pattern};
- my $domain = $item{domain};
- my $comment = $item{comment};
- my $hit_count = $item{hit_count};
+ for $item (@items) {
+ display_nolf "Adding $item->{pattern}\@$item->{domain} ($item->{comment}) to null list ($item->{sequence})...";
- display_nolf "Adding $pattern\@$domain ($comment) to null list ($nextseq)...";
+ last unless $item->{pattern} or $item->{domain};
- last if ((!defined $pattern || $pattern eq '') &&
- (!defined $domain || $domain eq ''));
+ $item->{sender} = CheckEmail $item->{pattern}, $item->{domain};
- $sender = lc ("$pattern\@$domain");
+ my ($status, $rule) = OnNulllist($item->{sender}, $userid);
- if (OnNulllist($sender)) {
+ if ($status == 0) {
display ' Already on list';
} else {
- Add2Nulllist($sender, $userid, $comment, $hit_count);
+ my ($message, $msg) = Add2Nulllist(%$item);
+
display ' done';
# Now remove this entry from the other lists (if present)
for my $otherlist ('white', 'black') {
- my $sth = FindList($otherlist, $sender);
- my ($sequence, $count);
-
- ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
-
- if ($sequence) {
- $count = DeleteList($otherlist, $sequence);
+ FindList(
+ userid => $item->{userid},
+ type => $otherlist,
+ sender => $item->{sender}
+ );
+
+ my $seq = GetList;
+
+ if ($seq->{sequence}) {
+ my $count = DeleteList(
+ userid => $item->{userid}
+ type => $otherlist,
+ sequence => $seq->{sequence}
+ );
+
+ display "Removed $item->{sender} from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $count > 0;
+
+ ResequenceList(
+ userid => $rec{userid},
+ type => $otherlist,
+ );
} # if
} # for
} # if
- $nextseq++;
+ $item->{sequence}++;
} # while
return;
#
# File: $RCSfile: add2whitelist.cgi,v $
# Revision: $Revision: 1.1 $
-# Description: Add an email address to the blacklist
+# Description: Add an email address to the whitlist
# Author: Andrew@DeFaria.com
# Created: Mon Jan 16 20:25:32 PST 2006
# Modified: $Date: 2013/06/12 14:05:47 $
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
+use Utils;
+
use MAPS;
use MAPSLog;
use MAPSWeb;
-use MAPSUtil;
use CGI qw/:standard *table/;
use CGI::Carp 'fatalsToBrowser';
-my $userid;
-my $Userid;
-my $type = 'white';
+sub Add2List(%) {
+ my (%rec) = @_;
+
+ CheckParms(['userid', 'type'], \%rec);
+
+ my $nextseq = GetNextSequenceNo(%rec);
-sub Add2List() {
- my $sender = '';
- my $nextseq = GetNextSequenceNo($userid, $type);
+ my $Userid = ucfirst $rec{userid};
while () {
- my $pattern = param "pattern$nextseq";
- my $domain = param "domain$nextseq";
- my $comment = param "comment$nextseq";
+ $rec{pattern} = param "pattern$nextseq";
+ $rec{domain} = param "domain$nextseq";
+ $rec{comment} = param "comment$nextseq";
+ $rec{hit_count} = param "hit_count$nextseq";
+ $rec{retention} = param "retention$nextseq";
- last if ((!defined $pattern || $pattern eq '') &&
- (!defined $domain || $domain eq ''));
+ last unless $rec{pattern} or $rec{domain};
- $sender = CheckEmail $pattern, $domain;
+ $rec{sender} = CheckEmail $rec{pattern}, $rec{domain};
- my ($status, $rule) = OnWhitelist($sender, $userid);
+ my ($status, $rule) = OnWhitelist($rec{sender}, $rec{userid});
if ($status != 0) {
- print br {-class => 'error'}, "The email address $sender is already on ${Userid}'s $type list";
+ print br {-class => 'error'},
+ "The email address $rec{sender} is already on ${Userid}'s $rec{type} list";
} else {
- my $messages = Add2Whitelist($sender, $userid, $comment);
+ my ($messages, $msg) = Add2Whitelist(%rec);
+
+ if ($messages < -1) {
+ print br {-class => 'error'}, "Unable to add $rec{sender} to $rec{type} list\n$msg";
+ return;
+ } else {
+ print br "The email address, $rec{sender}, has been added to ${Userid}'s $rec{type} list";
+ } # if
- print br "The email address, $sender, has been added to ${Userid}'s $type list";
if ($messages > 0) {
if ($messages == 1) {
print br 'Your previous message has been delivered';
} else {
print br "Your previous $messages messages have been delivered";
} # if
- } elsif ($messages == -1) {
- print br {-class => 'error'}, 'Unable to deliver message';
- } else {
+ } elsif ($messages == 0) {
print br 'Unable to find any old messages but future messages will now be delivered.';
+ } elsif ($messages < 0) {
+ print br {-class => 'error'}, $msg;
+
+ return;
} # if
# Now remove this entry from the other lists (if present)
for my $otherlist ('black', 'null') {
- my $sth = FindList($otherlist, $sender);
- my ($sequence, $count);
+ FindList(
+ userid => $rec{userid},
+ type => $otherlist,
+ sender => $rec{sender},
+ );
+
+ my $seq = GetList;
+
+ if ($seq->{sequence}) {
+ my $err;
- ($_, $_, $_, $_, $_, $sequence) = GetList($sth);
+ ($err, $msg) = DeleteList(
+ userid => $rec{userid},
+ type => $otherlist,
+ sequence => $seq->{sequence},
+ );
- if ($sequence) {
- $count = DeleteList($otherlist, $sequence);
- print br "Removed $sender from ${Userid}'s " . ucfirst $otherlist . ' list'
- if $count > 0;
+ croak $msg if $err < 0;
- ResequenceList($userid, $otherlist);
+ print br "Removed $rec{sender} from ${Userid}'s " . ucfirst $otherlist . ' list'
+ if $err > 0;
+
+ ResequenceList(
+ userid => $rec{userid},
+ type => $otherlist,
+ );
} # if
} # for
} # if
$nextseq++;
} # while
+
+ return;
} # Add2List
# Main
-$userid = Heading(
+my $userid = Heading(
'getcookie',
'',
'Add to White List',
$userid ||= $ENV{USER};
-$Userid = ucfirst $userid;
-
SetContext($userid);
NavigationBar($userid);
-Add2List;
+my $type = 'white';
+
+Add2List(
+ userid => $userid,
+ type => $type,
+);
print start_form {
-method => 'post',
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
my $userid;
if (param "user") {
- $userid = param("user");
+ $userid = param 'user';
} else {
- $userid = cookie("MAPSUser");
+ $userid = cookie 'MAPSUser';
} # if
+$userid //= $ENV{USER};
+
my $sender = param("sender");
sub Heading() {
print h3 {-align => "center",
-class => "header"},
"MAPS: Checking address $sender";
+
+ return;
} # Heading
sub Body() {
($onlist, $rule) = OnBlacklist($sender, 0);
if ($onlist) {
- print div {-align => "center"},
- font {-color => "black"},
+ print div {-align => "center"},
+ font {-color => "black"},
"Messages from", b ($sender), "will be", b ("blacklisted"), br, hr;
print $rule;
} else {
($onlist, $rule) = OnNulllist($sender, 0);
if ($onlist) {
- print div {-align => "center"},
- font {-color => "grey"},
+ print div {-align => "center"},
+ font {-color => "grey"},
"Messages from", b ($sender), "will be", b ("discarded"), br, hr;
print $rule;
} else {
- print div {-align => "center"},
- font {-color => "red"},
+ print div {-align => "center"},
+ font {-color => "red"},
"Messages from", b ($sender), "will be", b ("returned");
} # if
} # if
submit(-name => "submit",
-value => "Close",
-onClick => "window.close (self)");
+
+ return;
} # Body
sub Footing() {
print end_html;
+
+ return;
} # Footing
# Main
use warnings;
use MIME::Words qw(:all);
+
+use CGI qw(:standard *table start_td end_td start_Tr end_Tr start_div end_div);
+use CGI::Carp 'fatalsToBrowser';
+
use FindBin;
-$0 = $FindBin::Script;
+
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
-use MAPSUtil;
use MAPSWeb;
-use CGI qw(:standard *table start_td end_td start_Tr end_Tr start_div end_div);
-use CGI::Carp 'fatalsToBrowser';
+use DateUtils;
-my $type = param('type');
-my $next = param('next');
-my $lines = param('lines');
-my $date = param('date');
+my $type = param 'type';
+my $next = param 'next';
+my $lines = param 'lines';
+my $date = param 'date';
$date ||= '';
-my $userid;
-my $current;
-my $last;
-my $prev;
-my $total;
+my ($userid, $current, $last, $prev, $total);
+
my $table_name = 'detail';
my %types = (
]
);
-sub MakeButtons {
+sub MakeButtons($) {
my ($type) = @_;
my $prev_button = $prev >= 0 ?
$buttons = $buttons .
submit ({-name => 'action',
-value => 'Blacklist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Nulllist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Reset',
-onClick => 'return ClearAll (document.detail);'});
$buttons = $buttons .
submit ({-name => 'action',
-value => 'Whitelist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Nulllist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Reset',
-onClick => 'return ClearAll (document.detail);'});
$buttons = $buttons .
submit ({-name => 'action',
-value => 'Whitelist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Blacklist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Reset',
-onClick => 'return ClearAll (document.detail);'});
$buttons = $buttons .
submit ({-name => 'action',
-value => 'Whitelist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Blacklist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Nulllist',
- -onClick => 'return CheckAtLeast1Checked (document.detail);'}) .
+ -onClick => 'return CheckAtLeast1Checked (document.detail);'}) . ' ' .
submit ({-name => 'action',
-value => 'Reset',
-onClick => 'return ClearAll (document.detail);'});
return $buttons . $next_button;
} # MakeButtons
-sub PrintTable {
+sub Body($) {
my ($type) = @_;
my $current = $next + 1;
];
print end_div;
- for my $sender (ReturnSenders($userid, $type, $next, $lines, $date)) {
- my @msgs = ReturnMessages($userid, $sender);
- my @msgs2 = @msgs;
+ for my $sender (ReturnSenders(
+ userid => $userid,
+ type => $type,
+ start_at => $next,
+ lines => $lines,
+ date => $date
+ )) {
+ my $msgs = ReturnMessages(
+ userid => $userid,
+ sender => $sender,
+ );
+
+ # This is for the purposes of supplying a subject line if the mailto address
+ # is clicked on. It's kludgy because we are simply grabbing the subject line
+ # of the first email sent where there may be many emails from this sender.
+ # Still it is often the right subject (or a good enough one)
+ #
+ # A little tricky here because of transliteration. If I test for
+ # $msg->[0]{subject} when $msg->[0] is essentially empty I create the hash
+ # making it non empty. Therefore I need to first test if $msgs->[0] exists
+ # first.
+ my $heading = '';
+
+ if ($msgs->[0]) {
+ $heading = $msgs->[0]{subject} if $msgs->[0]{subject};
+ } # if
my ($onlist, $seq);
} # unless
if ($rule) {
- $rule =~ s/Matching rule: \(//;
- $rule =~ s/\)//;
-
- if ($rule =~ /(\w+):(\d+)/) {
+ if ($rule =~ /\((\w+):(\d+)\)\s+"(.*)"/) {
my $list = $1;
- my $sequence = $2 - 1;
- my $link = "<a href=\"/maps/php/list.php?type=$list&next=$sequence\">$list:$2</a>/$hit_count";
+ my $sequence = $2;
+ my $next = $sequence - 1;
+ $rule = $3;
- $rule =~ s/\w+:\d+/$link/;
+ $rule =~ s/\\@/\@/;
+
+ $rule = "<a href=\"/maps/php/list.php?type=$list&next=$next\">$list:$sequence</a>/$hit_count $rule";
} # if
} # if
-bgcolor => '#d4d0c8'};
# Get subject line
- my $heading = $msgs2[0][0] || '';
$heading = "?subject=$heading" if $heading;
print
td {-class => 'tablelabel',
my $messages = 1;
- for (@msgs) {
- my $msg_date = pop @{$_};
- my $link_date = $msg_date;
- my $subject = pop @{$_};
-
- if ($date eq substr ($msg_date, 0, 10)) {
- $msg_date = b font {-color => 'green'}, SQLDatetime2UnixDatetime $msg_date;
+ for my $rec (@$msgs) {
+ if ($date eq substr ($rec->{timestamp}, 0, 10)) {
+ $rec->{date} = b font {-color => 'green'}, SQLDatetime2UnixDatetime $rec->{timestamp};
} else {
- $msg_date = SQLDatetime2UnixDatetime $msg_date;
+ $rec->{date} = SQLDatetime2UnixDatetime $rec->{timestamp};
} # if
- $subject = $subject eq '' ? '<Unspecified>' : $subject;
- $subject = decode_mimewords ($subject);
- $subject =~ s/\>/>/g;
- $subject =~ s/\</</g;
+ $rec->{subject} //= '<Unspecified>';
+ $rec->{subject} = decode_mimewords ($rec->{subject});
+ $rec->{subject} =~ s/\>/>/g;
+ $rec->{subject} =~ s/\</</g;
print
start_table {-class => 'tablerightdata',
td {-class => 'subject',
-valign => 'middle',
-bgcolor => '#ffffff'},
- a {-href => "display.cgi?sender=$sender;msg_date=$link_date"}, $subject,
+ a {-href => "display.cgi?sender=$sender;msg_date=$rec->{timestamp}"}, $rec->{subject},
td {-class => 'date',
-width => '150',
- -valign => 'middle'}, $msg_date
+ -valign => 'middle'}, $rec->{date},
];
print end_table;
} # for
print end_form;
return;
-} # PrintTable
+} # Body
# Main
my $condition;
my @scripts = ('ListActions.js');
-my $heading_date =$date ne '' ? ' on ' . FormatDate ($date) : '';
+my $heading_date =$date ne '' ? ' on ' . FormatDate ($date, 1) : '';
$userid = Heading(
'getcookie',
'',
(ucfirst ($type) . ' Report'),
- $types {$type} [0],
- $types {$type} [1] . $heading_date,
+ $types{$type} [0],
+ $types{$type} [1] . $heading_date,
$table_name,
@scripts
);
} # unless
if ($date eq '') {
- $condition .= "userid = '$userid' and type = '$type'";
+ $condition .= "type = '$type'";
} else {
my $sod = $date . ' 00:00:00';
my $eod = $date . ' 23:59:59';
- $condition .= "userid = '$userid' and type = '$type' "
- . "and timestamp > '$sod' and timestamp < '$eod' ";
+ $condition .= "type = '$type' and timestamp > '$sod' and timestamp < '$eod'";
} # if
-$total = count_distinct('log', 'sender', $condition);
+$total = CountLog(
+ userid => $userid,
+ additional => $condition,
+);
$next ||= 0;
$prev = $next == 0 ? -1 : 0;
} # if
-PrintTable($type);
+Body($type);
Footing($table_name);
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
use MIME::Base64;
use MIME::Words qw(:all);
-my $userid = cookie('MAPSUser');
-my $sender = param('sender');
+my $userid = cookie('MAPSUser');
+my $sender = param('sender');
# CGI will replace '+' with ' ', which many mailers are starting to do,
# so add it back
$sender =~ s/ /\+/;
-my $msg_date = param('msg_date');
-my $table_name = 'message';
+my $msg_date = param('msg_date');
+my $table_name = 'message';
sub ParseEmail(@) {
my (@header) = @_;
my ($date) = @_;
# Find unique message using $date
- my $handle = FindEmail $sender, $date;
+ my ($err, $msg) = FindEmail(
+ userid => $userid,
+ sender => $sender,
+ timestamp => $date,
+ );
- my ($userid, $sender, $subject, $timestamp, $message) = GetEmail $handle;
+ my $rec = GetEmail;
my $parser = MIME::Parser->new();
$parser->output_to_core(1);
+ $parser->tmp_to_core(1);
- my $entity = $parser->parse_data ($message);
+ my $entity = $parser->parse_data($rec->{data});
my %header = ParseEmail @{($entity->header)[0]};
-cellpadding => 0,
-width => "100%"});
print start_table ({-align => "center",
- -bgcolor => "#d4d0c8",
+ -bgcolor => 'steelblue',
+ #-bgcolor => "#d4d0c8",
-border => 0,
-cellspacing => 2,
-cellpadding => 2,
-border => 0,
-cellspacing => 0,
-cellpadding => 2,
- -bgcolor => "#ece9d8",
+ -bgcolor => 'black',
+ #-bgcolor => "#ece9d8",
-width => "100%"}) . "\n";
for (keys (%header)) {
my $str = decode_mimewords($header{$_});
print Tr ([
- th ({-align => "right",
- -bgcolor => "#ece9d8",
- -width => "8%"}, "$_:") . "\n" .
- td ({-bgcolor => "white"}, $str)
+ th ({-align => 'right',
+ -bgcolor => 'steelblue',
+ -style => 'color: white',
+ #-bgcolor => "#ece9d8",
+ -width => "8%"}, ucfirst "$_:") . "\n" .
+ td ({-bgcolor => 'white'}, $str)
]);
} # for
print "</td></tr>";
print end_table;
- print start_table ({-align => "center",
- -bgcolor => "black",
+ print start_table ({-align => 'center',
+ -bgcolor => 'steelblue',
-border => 0,
-cellspacing => 0,
-cellpadding => 2,
-border => 0,
-cellspacing => 0,
-cellpadding => 2,
- -bgcolor => "white",
+ -bgcolor => 'white',
-width => "100%"}) . "\n";
print "<tbody><tr><td>\n";
print $entity->{ME_Bodyhandle}{MBS_Data};
} else {
print '<pre>';
- $entity->print_body;
+ print $entity->print_body;
print '</pre>';
} # if
} else {
# There should be an easier way to get this but I couldn't find one.
my $encoding = ${$subpart->{mail_inet_head}{mail_hdr_hash}{'Content-Transfer-Encoding'}[0]};
if ($encoding =~ /base64/) {
- $subpart->bodyhandle->print();
+ $subpart->bodayhandle->print;
} else {
- $subpart->print_body;
+ print $subpart->print_body;
} # if
last;
} elsif ($subpart->mime_type eq 'multipart/related') {
$part->bodyhandle->print();
} else {
print '<pre>';
- $part->print_body;
+ print $part->print_body;
print '</pre>';
} # if
} # if
$table_name,
);
+$userid //= $ENV{USER};
+
SetContext($userid);
NavigationBar($userid);
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: domains,v $
-# Revision: $Revision: 1.1 $
-# Description: Display entries from the list table where there is at least one
-# entry with a null pattern (nuke the domain) and yet still other
-# entries with the same domain name but having a pattern. We may
-# want to eliminate the other entries since we're nuking the
-# whole domain anyway.
-# Author: Andrew@DeFaria.com
-# Created: Sat Oct 20 23:28:19 MST 2007
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: Perl
-#
-# (c) Copyright 2007, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-use strict;
-use warnings;
-
-use FindBin;
-use Getopt::Long;
-
-use lib "$FindBin::Bin/../lib", '/opt/clearscm/lib';
-
-use MAPS;
-use Display;
-
-sub Usage () {
- display <<END;
-$FindBin::Script { -verbose } { -debug } { -usage }
-END
-
- exit 1;
-} # Usage
-
-GetOptions (
- "verbose" => sub { set_verbose },
- "debug" => sub { set_debug },
- "usage" => sub { Usage },
-) || Usage;
-
-my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
-
-# Main
-SetContext $userid;
-
-my $statement = "select domain from list where userid=\"$userid\" and type=\"null\" and pattern is null";
-
-my $need_resequence = 0;
-
-for my $domain (sort (GetRows($statement))) {
- verbose "Processing domain $domain";
- $statement = "select sequence from list where userid = \"$userid\" and domain = \"$domain\" and type = \"null\" and pattern is not null";
-
- for my $sequence (GetRows $statement) {
- display "Deleting $domain ($sequence)";
- $need_resequence = 1;
- DeleteList "null", $sequence;
- } # for
-} # for
-
-if ($need_resequence) {
- verbose "Resequencing null list...";
- ResequenceList $userid, "null";
- verbose "done";
-} # if
-
-exit;
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
my $table_name = 'profile';
sub Body() {
- my $handle = FindUser($userid);
+ FindUser(userid => $userid);
- my ($fullname, $email, $password);
- ($_, $fullname, $email, $password) = GetUser($handle);
-
- $handle->finish;
+ my $rec = GetUser;
my %options = GetUserOptions($userid);
};
print start_table {
-align => 'center',
+ -bgcolor => 'white',
-id => $table_name,
-border => 1,
-cellspacing => 0,
textfield {-class => 'inputfield',
-size => 50,
-name => 'fullname',
- -value => $fullname}),
+ -value => $rec->{name}}),
td {-class => 'notetext'},'Specify your full name'
]) . "\n";
print Tr [
textfield {-class => 'inputfield',
-size => 50,
-name => 'email',
- -value => $email}),
+ -value => $rec->{email}}),
td {-class => 'notetext'},'Your email address is used if you are a ' .
i ("Tag & Forward") .
' user. This is the email address that MAPS will forward your email to after it tags it. This email address is also used in case you forget your password so that we can email you your password.'
submit (-name => 'submit',
-value => 'Update Profile'));
print end_form;
+
+ return;
} # Body
# Main
@scripts
);
+$userid //= $ENV{USER};
+
SetContext $userid;
NavigationBar $userid;
my $year = substr((scalar(localtime)), 20, 4);
- my ($pattern, $domain, $comment, $hit_count, $last_hit);
- my $sth = FindList($type);
-
print "\################################################################################\n";
print "\#\n";
print "\# MAPS:\t\tMail Authorization and Permission System (MAPS)\n";
print "\#\n";
print "\################################################################################\n";
- while (($_, $_, $pattern, $domain, $comment, $_, $hit_count, $last_hit) = GetList($sth)) {
- last if !(defined $pattern or defined $domain);
-
- $pattern //= '';
- $domain //= '';
-
- if ($domain eq '') {
- print "$pattern,$comment,$hit_count,$last_hit\n";
+ FindList(
+ userid => $userid,
+ type => $type,
+ );
+
+ while (my $rec = GetList) {
+ $rec->{pattern} //= '';
+ $rec->{domain} //= '';
+ $rec->{comment} //= '';
+ $rec->{hit_count} //= 0;
+ $rec->{last_hit} //= '';
+ $rec->{retention} //= '';
+
+ if ($rec->{domain} eq '') {
+ print "$rec->{pattern},$rec->{comment},$rec->{hit_count},$rec->{last_hit},$rec->{retention}\n";
} else {
- print "$pattern\@$domain,$comment,$hit_count,$last_hit\n";
+ print "$rec->{pattern}\@$rec->{domain},$rec->{comment},$rec->{hit_count},$rec->{last_hit},$rec->{retention}\n";
} # if
} # while
#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: importlist.cgi,v $
-# Revision: $Revision: 1.1 $
-# Description: Export an address list
-# Author: Andrew@DeFaria.com
-# Created: Mon Jan 16 20:25:32 PST 2006
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
+
+=pod
+
+=head1 NAME $RCSfile: importlist.cgi,v $
+
+Imports a white, black or null list into MAPS
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@DeFaria.com>
+
+=item Revision
+
+$Revision: 1.1 $
+
+=item Created:
+
+Mon Jan 16 20:25:32 PST 2006
+
+=item Modified:
+
+$Date: 2019/04/04 13:40:10 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage; importlist.cgi [-usa|ge] [-h|elp] [-v|erbose] [-de|bug]
+ [-type <white|black|null>] [-file <filename>]
+
+ Where:
+ -usa|ge Print this usage
+ -h|elp Detailed help
+ -v|erbose Verbose mode (Default: Not verbose)
+ -de|bug Turn on debugging (Default: Off)
+
+ -t|ype Type of list - white, black or null
+ -f|ile File to import
+
+=head1 DESCRIPTION
+
+This script will import list entries from a list file for white, black or null
+lists. Normally this script is run from the Import List button.
+
+=cut
+
use strict;
+use warnings;
use FindBin;
local $0 = $FindBin::Script;
use Getopt::Long;
use Pod::Usage;
+use Display;
use MAPS;
use MAPSWeb;
use CGI qw/:standard *table/;
use CGI::Carp "fatalsToBrowser";
-my $userid = cookie('MAPSUser');
- $userid //= $ENV{USER};
-my $Userid = ucfirst $userid;
-
-my $type = param 'type';
-my $file = param 'file';
+my ($userid, $Userid);
my %opts = (
- usage => sub { pod2usage },
- help => sub { pod2usage (-verbose => 2)},
- type => $type,
- file => $file,
+ usage => sub { pod2usage },
+ help => sub { pod2usage(-verbose => 2)},
+ verbose => sub { set_verbose },
+ debug => sub { set_debug },
);
-sub importList ($) {
- my ($type) = @_;
+$opts{type} = param 'type';
+$opts{file} = param 'filename';
+
+die "File not specified" unless $opts{file};
+
+sub importList ($$) {
+ my ($list, $type) = @_;
my $count = 0;
- open my $file, '<', $opts{file}
- or die "Unable to open $opts{file} - $!\n";
+ my @output;
- while (<$file>) {
+ $| = 1;
+ while (<$list>) {
next if /^\s*#/;
chomp;
- my ($pattern, $comment, $hit_count, $last_hit) = split /,/;
+ my ($sender, $comment, $hit_count, $last_hit, $retention) = split /,/;
my $alreadyExists;
+ # The code for checking if a sender is on a list does not expect the $sender
+ # to have any regexs
+ my $cleansedSender = $sender;
+
+ $cleansedSender =~ s/(\^|\+)//g;
+
+ # TODO: While this works well for real email addresses it does not handle
+ # our regexes. True it can weed out some duplicates where a more specific
+ # email address is already covered by a more general regex. For example,
+ # I may have say andrew@someplace.ru in a null list but also have say
+ # ".*\.ru$" which covers andrew@someplace.ru. Using On<List>list functions
+ # will always see ".*\.ru$" as nonexistant and readd it.
if ($type eq 'white') {
- ($alreadyExists) = OnWhitelist($pattern, $userid);
+ ($alreadyExists) = OnWhitelist($cleansedSender, $userid);
} elsif ($type eq 'black') {
- ($alreadyExists) = OnBlacklist($pattern, $userid);
+ ($alreadyExists) = OnBlacklist($cleansedSender, $userid);
} elsif ($type eq 'null') {
- ($alreadyExists) = OnNulllist($pattern, $userid);
+ ($alreadyExists) = OnNulllist($cleansedSender, $userid);
} # if
unless ($alreadyExists) {
- AddList($type, $pattern, 0, $comment, $hit_count, $last_hit);
+ # Some senders lack '@' as they are username only senders. But AddList
+ # complains if there is no '@'. For such senders tack on a '@'n
+ if ($sender !~ /\@/) {
+ $sender .= '@';
+ } # if
+
+ AddList(
+ userid => $userid,
+ type => $type,
+ sender => $sender,
+ sequence => 0,
+ comment => $comment,
+ hit_count => $hit_count,
+ last_hit => $last_hit,
+ retention => $retention,
+ );
+
+ print "Added $sender to ${Userid}'s ${type}list<br>";
+ push @output, "Added $sender to ${Userid}'s ${type}list<br>";
$count++;
} else {
- print br "$pattern is already on your " . ucfirst($type) . 'list';
+ push @output, "$sender is already on your " . ucfirst($type) . 'list<br>';
} # unless
} # while
- close $file;
+ print $_ for @output;
return $count;
} # importList
'help',
'verbose',
'debug',
- 'file=s',
+ #'file=s',
'type=s',
);
-pod2usage "Type not specified" unless $opts{type};
-pod2usage '-file should be specified' unless $opts{file};
-pod2usage "Unable to read $opts{file}" unless -r $opts{file};
+pod2usage 'Type not specified' unless $opts{type};
+pod2usage 'File not specified' unless $opts{file};
+
+# Now let's see if we can get that file
+my $list = upload('filename');
+
+#pod2usage "Unable to read $opts{file}" unless -r $opts{file};
$userid = Heading(
'getcookie',
'Import List',
);
+$userid //= $ENV{USER};
+$Userid = ucfirst $userid;
+
SetContext($userid);
NavigationBar($userid);
-my $count = importList($opts{type});
+my $count = importList($list, $opts{type});
if ($count == 1) {
print br "$count list entry imported";
if ($onlist) {
verbose "Blacklisting $sender";
- my @msg = split /\n/, $data;
- Blacklist $sender, $sequence, $hit_count, @msg;
+ Blacklist(
+ userid => $userid,
+ sender => $sender,
+ sequence => $sequence,
+ hit_count => $hit_count,
+ data => $data,
+ );
+
next;
} # if
# Return processing:
verbose "Returning message from $sender";
- ReturnMsg $sender, $reply_to, $subject, $data;
+ ReturnMsg(
+ userid => $userid,
+ sender => $sender,
+ reply_to => $reply_to,
+ subject => $subject,
+ data => $data,
+ );
} # while
} # ProcessMsgs
my $msgfile;
if ($ARGV[0] and $ARGV[0] ne "") {
- open $msgfile, $ARGV[0];
+ open $msgfile, '<', $ARGV[0];
- if (!$msgfile) {
+ unless ($msgfile) {
Error "Unable to open file ($ARGV[0]): $!\n";
exit 1;
} # if
verbose "Starting MAPS....";
-my ($username, $user_email) = SetContext $userid
+my %userOptions = SetContext $userid
or die "$userid is not a registered MAPS user\n";
-ProcessMsgs $msgfile, $username, $user_email;
+ProcessMsgs $msgfile, $userOptions{name}, $userOptions{email};
exit 0;
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: mapsscrub,v $
-# Revision: $Revision: 1.1 $
-# Description: This script scrubs messages from the MAPS database based on the
-# users settings.
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-use strict;
-use warnings;
-
-use FindBin;
-
-use lib "$FindBin::Bin/../lib";
-
-use MAPS;
-use MAPSUtil;
-
-my $userid;
-my $verbose = defined $ARGV[0] && $ARGV[0] eq "-v" ? 1 : 0;
-my $total_emails = 0;
-my $total_log_entries = 0;
-my $total_list_entries = 0;
-my $total_users_emails = 0;
-
-my ($history, $nbr_emails, $nbr_log_entries, $nbr_list_entries, $users_emails);
-
-format =
-@<<<<<<<<<<<<<<<< @>> @##### @##### @##### @#####
-$userid,$history,$nbr_emails,$nbr_log_entries,$nbr_list_entries,$users_emails
-.
-format STDOUT_TOP =
-@||||||||||||||||||||||||||||||||||||||||||||||||
-"MAPS Scrubber"
-
-User ID Age Email Log List User's Emails
------------------ --- ------ ------ ------ -------------
-.
-
-sub verbose($) {
- my ($msg) = @_;
-
- return if $verbose == 0;
-
- print "$msg\n";
-} # verbose
-
-sub CleanUp($) {
- my ($userid) = @_;
-
- my %options = GetUserOptions($userid);
-
- $history = $options{"History"};
-
- my $timestamp = SubtractDays(Today2SQLDatetime, $history);
-
- $nbr_emails = CleanEmail $timestamp;
- $nbr_log_entries = CleanLog $timestamp;
- $nbr_list_entries = CleanList $timestamp, "null";
- $users_emails = count("email", "userid = \"$userid\"");
-
- write () if $verbose;
-
- return ($nbr_emails, $nbr_log_entries, $nbr_list_entries, $users_emails);
-} # CleanUp
-
-# Main
-my $handle = FindUser;
-
-#$~ = "REPORT" if $verbose;
-
-while (($userid) = GetUser($handle)) {
- last unless $userid;
-
- SetContext($userid);
-
- my ($emails, $log_entries, $list_entries, $users_emails) = CleanUp($userid);
-
- $total_emails += $emails;
- $total_log_entries += $log_entries;
- $total_list_entries += $list_entries;
- $total_users_emails += $users_emails;
-} # while
-
-$handle->finish;
-
-if ($verbose) {
- $userid = "Total:";
- $history = "n/a";
- $nbr_emails = $total_emails;
- $nbr_log_entries = $total_log_entries;
- $nbr_list_entries = $total_list_entries;
- $users_emails = $total_users_emails;
- write();
-} # if
-
-# Now optimize the database
-OptimizeDB;
-
-exit;
--- /dev/null
+#!/usr/bin/perl
+
+=pod
+
+=head1 NAME $RCSfile: mapsscrub,v $
+
+This script scrubs messages from the MAPS database based on the users settings
+
+=head1 VERSION
+
+=over
+
+=item Author
+
+Andrew DeFaria <Andrew@DeFaria.com>
+
+$Revision: 1.1 $
+
+=item Created:
+
+Fri Nov 29 14:17:21 2002
+
+=item Modified:
+
+$Date: 2013/06/12 14:05:47 $
+
+=back
+
+=head1 SYNOPSIS
+
+ Usage: mapsscrub.pl [-usa|ge] [-h|elp] [-v|erbose] [-de|bug]
+ [-n|optimize]
+
+ Where:
+ -usa|ge Print this usage
+ -h|elp Detailed help
+ -v|erbose Verbose mode (Default: Not verbose)
+ -de|bug Turn on debugging (Default: Off)
+
+ -user|id User ID to scrub (Default: All users)
+ -n\oopitmize Whether or not to optimize DB (Default: optimize)
+
+=cut
+
+use strict;
+use warnings;
+
+use FindBin;
+
+use lib "$FindBin::Bin/../lib";
+use lib "$FindBin::Bin/../../lib";
+
+use Getopt::Long;
+use Pod::Usage;
+
+use DateUtils;
+use Logger;
+use MAPS;
+use Utils;
+
+my %opts = (
+ usage => sub { pod2usage },
+ help => sub { pod2usage (-verbose => 2)},
+ optimize => 1,
+);
+
+my ($userid, $log, %total);
+
+sub CleanUp($) {
+ my ($userid) = @_;
+
+ my %options = GetUserOptions($userid);
+
+ my $timestamp = SubtractDays(Today2SQLDatetime, $options{History});
+
+ $total{'Emails cleaned'} = CleanEmail $timestamp;
+ $total{'Log entries removed'} = CleanLog $timestamp;
+
+ for (qw(white black null)) {
+ $total{"${_}list entries removed"} = CleanList(
+ userid => $userid,
+ type => $_,
+ log => $log,
+ );
+ } # for
+
+ Stats \%total, $log;
+
+ return;
+} # CleanUp
+
+# Main
+GetOptions(
+ \%opts,
+ 'usage',
+ 'help',
+ 'verbose',
+ 'debug',
+ 'userid=s',
+ 'optimize!',
+) or pod2usage;
+
+$log = Logger->new(
+ path => '/var/local/log',
+ timestamped => 'yes',
+);
+
+FindUser(%opts{userid});
+
+#$~ = "REPORT" if $verbose;
+
+while (my $rec = GetUser) {
+ SetContext($rec->{userid});
+
+ CleanUp($rec->{userid});
+} # while
+
+# Now optimize the database
+OptimizeDB if $opts{optimize};
+
+exit;
use strict;
use warnings;
+use 5.030;
+
+# For use of the given/when (See https://perlmaven.com/switch-case-statement-in-perl5)
+no warnings 'experimental';
+
use FindBin;
+use Term::ReadKey;
+
use lib "$FindBin::Bin/../lib";
+use lib "$FindBin::Bin/../../lib";
use MAPS;
use MAPSLog;
-
-use Term::ReadLine;
-use Term::ReadLine::Gnu;
-use Term::ReadKey;
-
-my $maps_username;
+use MyDB;
+
+use CmdLine;
+use Utils;
+
+my %cmds = (
+ adduser => {
+ help => 'Add a user to MAPS',
+ description => 'Usage: adduser <userid> <name> <email> <password>',
+ },
+ add2whitelist => {
+ help => 'Add sender to whitelist',
+ description => 'Usage: add2whitelist <sender> <retention>',
+ },
+ cleanlog => {
+ help => 'Cleans out old log entries',
+ description => 'Usage; cleanlog [timestamp]'
+ },
+ log => {
+ help => 'Logs a message',
+ description => 'Usage: log <message>',
+ },
+ loadlist => {
+ help => 'Load a list file',
+ description => 'Usage: loadlist <listfile>',
+ },
+ cleanemail => {
+ help => 'Cleans out old email entries',
+ description => 'Usage: cleanemail [timestamp]',
+ },
+ deliver => {
+ help => 'Delivers a message',
+ description => 'Usage: deliver <message>',
+ },
+ loademail => {
+ help => 'Load an mbox file',
+ description => 'Usage: loademail <mbox>',
+ },
+ dumpemail => {
+ help => 'Dump email from DB to mbox file',
+ description => 'Usage: ',
+ },
+ decrypt => {
+ help => 'Decrypt a password',
+ description => 'Usage: decrypt <password>',
+ },
+ switchuser => {
+ help => 'Switch to user',
+ description => 'Usage: switchuser <userid>',
+ },
+ setpassword => {
+ help => "Set a user's password",
+ description => 'Usage: setpassword',
+ },
+ showuser => {
+ help => 'Show current user',
+ description => 'Usage: showuser',
+ },
+ showusers => {
+ help => 'Shows users in the DB',
+ description => 'Usage: showusers',
+ },
+ showemail => {
+ help => 'Displays email',
+ description => 'Usage: showemail',
+ },
+ showlog => {
+ help => 'Displays <nbr> log entires',
+ description => 'Usage: showlog <nbr>',
+ },
+ space => {
+ help => 'Display space usage',
+ description => 'Usage: space',
+ },
+ showlist => {
+ help => 'Show list by <type>',
+ description => 'Usage: showlist <type>',
+ },
+ encrypt => {
+ help => 'Encrypt a password',
+ description => 'Usage: encrypt <password>',
+ },
+ resequence => {
+ help => 'Resequences a <list>',
+ description => 'Usage: resequence <list>',
+ },
+);
+
+my $userid = GetContext;
sub EncryptPassword($$) {
my ($password, $userid) = @_;
my $encrypted_password = Encrypt $password, $userid;
- print "Password: $password = $encrypted_password\n";
+ say "Encrypted password: '$encrypted_password'";
return;
} # EncryptPassword
my $decrypted_password = Decrypt($password, $userid);
- print "Password: $password = $decrypted_password\n";
+ say "Decrypted password: $decrypted_password";
return;
} # DecryptPassword
sub Resequence($$) {
my ($userid, $type) = @_;
- MAPS::ResequenceList($userid, $type);
+ ResequenceList(
+ userid => $userid,
+ type => $type,
+ );
} # Resequence
-sub GetPassword() {
- print "Password:";
- ReadMode "noecho";
- my $password = ReadLine(0);
- chomp $password;
- print "\n";
- ReadMode "normal";
-
- return $password;
-} # GetPassword
-
sub Login2MAPS($;$) {
my ($username, $password) = @_;
if ($username ne '') {
- $password = GetPassword if !defined $password or $password eq "";
+ $password = GetPassword unless $password;
} # if
while (Login($username, $password) != 0) {
- print "Login failed!\n";
+ say "Login failed!";
+
print "Username:";
+
$username = <>;
- if ($username eq "") {
- print "Login aborted!\n";
+
+ if ($username eq '') {
+ say "Login aborted!";
+
return undef;
} # if
+
chomp $username;
+
$password = GetPassword;
} # if
} elsif ($listfilename eq "null.list") {
$listtype = "null";
} else {
- print "Unknown list file: $listfilename\n";
+ say "Unknown list file: $listfilename";
return;
} # if
my $listfile;
if (!open $listfile, '<', $listfilename) {
- print "Unable to open $listfilename\n";
+ say "Unable to open $listfilename";
return;
} # if
} # while
if ($sequence == 0) {
- print "No messages found to load ";
+ say "No messages found to load";
} elsif ($sequence == 1) {
- print "Loaded 1 message ";
+ say "Loaded 1 message ";
} else {
- print "Loaded $sequence messages ";
+ say "Loaded $sequence messages";
} # if
- print "from $listfilename\n";
+
+ say "from $listfilename";
close $listfile;
} # LoadListFile
my $file;
- if (!open $file, '<', $filename) {
- print "Unable to open \"$filename\" - $!\n";
- return;
- } # if
+ open $file, '<', $filename
+ or die "Unable to open \"$filename\" - $!\n";
binmode $file;
$nbr_msgs++;
- AddEmail($sender, $subject, $data);
+ AddEmail(
+ userid => $userid,
+ sender => $sender,
+ subject => $subject,
+ data => $data,
+ );
Info("Added message from $sender to email");
} # while
if ($nbr_msgs == 0) {
- print "No messages found to load ";
+ say "No messages found to load";
} elsif ($nbr_msgs == 1) {
- print "Loaded 1 message ";
+ say "Loaded 1 message";
} else {
- print "Loaded $nbr_msgs messages ";
+ say "Loaded $nbr_msgs messages";
} # if
- print "from $file\n";
+
+ say "from $file";
} # LoadEmail
sub DumpEmail($) {
my $file;
- if (!open $file, '>', $filename) {
- print "Unable to open \"$filename\" - $!\n";
- return;
- } # if
+ open $file, '>', $filename or
+ die "Unable to open \"$filename\" - $!\n";
binmode $file;
- my $i = 0;
- my $handle = FindEmail;
-
- my ($userid, $sender, $subject, $timestamp, $message);
+ my $i = 0;
+
+ my ($err, $msg) = $MAPS::db->find(
+ 'email',
+ "userid = '$userid'",
+ qw(data),
+ );
+
+ croak $msg if $msg;
- while (($userid, $sender, $subject, $timestamp, $message) = GetEmail($handle)) {
- print $file $message;
+ while (my $rec = $MAPS::db->getnext) {
+ say $file $rec->{data};
$i++;
} # while
- print "$i messages dumped to $file\n";
+ say "$i messages dumped to $file";
close $file;
} # DumpEmail
my ($new_user) = @_;
if ($new_user = Login2MAPS($new_user)) {
- print "You are now logged in as $new_user\n";
+ say "You are now logged in as $new_user";
} # if
} # SwitchContext
-sub ShowSpace($) {
- my ($detail) = @_;
+sub SetPassword() {
+ FindUser(userid => $userid);
- my $userid = GetContext;
+ my $rec = GetUser;
- if ($detail) {
- my %msg_space = Space($userid);
+ return unless $rec;
- for (sort (keys (%msg_space))) {
- my $sender = $_;
- my $size = $msg_space{$_};
- format PER_MSG=
-@######### @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
-$size,$sender
-.
-$~ = "PER_MSG";
- write ();
- } # foreach
+ my $password = GetPassword('Enter new password');
+ my $repeat = GetPassword('Enter new password again');
+
+ if ($password ne $repeat) {
+ say "Passwords don't match!";
} else {
- my $total_space = Space($userid);
+ $rec->{password} = Encrypt($password, $userid);
+
+ UpdateUser(%$rec);
- $total_space = $total_space / (1024 * 1024);
+ say "Password updated";
+ } # if
+
+ return;
+} # SetPassword
- format TOTALSIZE=
+sub ShowSpace() {
+ my $userid = GetContext;
+
+ my $total_space = Space($userid);
+
+ $total_space = $total_space / (1024 * 1024);
+
+ format TOTALSIZE=
Total size @###.### Meg
$total_space
.
$~ = "TOTALSIZE";
- write ();
- } # if
+
+ write();
} # ShowSpace
sub ShowUser() {
- print "Current userid is " . GetContext() . "\n";
+ say "Current userid is " . GetContext();
} # ShowContext
sub ShowUsers() {
- my ($handle) = FindUser;
+ FindUser(
+ fields => ['userid', 'name', 'email'],
+ );
- my ($userid, $name, $email);
+ my $rec;
format USERLIST =
User ID: @<<<<<<<<< Name: @<<<<<<<<<<<<<<<<<<< Email: @<<<<<<<<<<<<<<<<<<<<<<<
-$userid,$name,$email
+$rec->{userid},$rec->{name},$rec->{email}
.
$~ = "USERLIST";
- while (($userid, $name, $email) = GetUser($handle)) {
- last if ! defined $userid;
- write();
+ while ($rec = GetUser) {
+ last unless $rec->{userid};
+ write;
} # while
-
- $handle->finish;
} # ShowUsers
sub ShowEmail() {
- my ($handle) = FindEmail;
+ my ($err, $msg) = $MAPS::db->find(
+ 'email',
+ "userid='$userid'",
+ qw(userid timestamp sender subject),
+ );
- my ($userid, $sender, $subject, $timestamp, $message);
+my ($timestamp, $sender, $subject);
format EMAIL =
@<<<<<<<<<<<<<<<<<<<@<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$timestamp,$sender,$subject
.
+
$~ = "EMAIL";
- while (($userid, $sender, $subject, $timestamp, $message) = GetEmail($handle)) {
- last unless $userid;
+ while (my $rec = $MAPS::db->getnext) {
+ last unless $rec->{userid};
+
+ $timestamp = $rec->{timestamp};
+ $sender = $rec->{sender};
+ $subject = $rec->{subject};
+
write();
} # while
-
- $handle->finish;
} # ShowEmail
sub ShowLog($) {
$timestamp,$type,$sender,$message
.
$~ = "LOG";
- while (($userid, $timestamp, $sender, $type, $message) = GetLog $handle) {
- last unless $userid;
- write();
+
+ my $count = 0;
+
+ while (my $rec = GetLog) {
+ $timestamp = $rec->{timestamp} || '';
+ $type = $rec->{type} || '';
+ $sender = $rec->{sender} || '';
+ $message = $rec->{message} || '';
+
+ $count++;
+
+ last if $count > $how_many;
+
+ write;
} # while
- $handle->finish;
+ return;
} # ShowLog
sub ShowList($) {
.
$~ = "LIST";
- while (@list = ReturnList($type, $next, $lines)) {
- for (@list) {
- %record = %{$_};
+ # TODO: Why does ReturnList return a one entry array with a many entry array
+ # of hashes. Seems it should just return $list[0], right?
+ while (@list = ReturnList(
+ userid => $userid,
+ type => $type,
+ start_at => $next,
+ lines => $lines)) {
+ for (@{$list[0]}) {
+ %record = %$_;
+
+ # Format blows up if any field is undefined so...
+ $record{pattern} //= '';
+ $record{domain} //= '';
+ $record{comment} //= '';
write();
} # for
- print "Hit any key to continue";
- ReadLine (0);
+
+ print 'Hit any key to continue - q to quit';
+
+ ReadMode 'raw';
+ my $key = ReadKey(0);
+ ReadMode 'normal';
+
+ if ($key eq 'q' or ord $key == 67) {
+ print "\n";
+
+ last;
+ } # if
+
+ print "\r";
+
$next += $lines;
} # while
+
+ return;
} # ShowList
sub ShowStats($) {
$nbr_days ||= 1;
- my %dates = GetStats($nbr_days);
+ my %dates = GetStats(
+ userid => $userid,
+ days => $nbr_days,
+ );
for my $date (keys(%dates)) {
for (keys(%{$dates{$date}})) {
- print "$date $_:";
- print "\t$dates{$date}{$_}\n";
+ say "$date $_:";
+ say "\t$dates{$date}{$_}";
} # for
} # for
} # ShowStats
my $message;
if (!open $message, '<', $filename) {
- print "Unable to open message file $filename\n";
+ say "Unable to open message file $filename";
return;
} # if
return;
} # Deliver
-sub ParseCommand($$$$$){
- my ($cmd, $parm1, $parm2, $parm3,$parm4) = @_;
+sub ExecuteCmd($){
+ my ($line) = @_;
- $_ = $cmd . ' ';
+ my ($cmd, $parm1, $parm2, $parm3, $parm4) = split /\s+/, $line;
- SWITCH: {
- /^$/ && do {
- last SWITCH
- };
+ given ($cmd) {
+ when (!$_) {
+ return;
+ } # when
- /^resequence / && do {
+ when (/^\s*resequence\s*$/) {
Resequence(GetContext(), $parm1);
- last SWITCH
- };
+ } # when
- /^encrypt / && do {
- EncryptPassword($parm1, $parm2);
- last SWITCH
- };
+ when (/^s*encrypt\s*$/) {
+ EncryptPassword($parm1, $userid);
+ } # when
- /^decrypt / && do {
- my $password = UserExists(GetContext());
- DecryptPassword($password, $maps_username);
- last SWITCH
- };
+ when (/^\s*encrypt\s*$/) {
+ EncryptPassword($parm1, $userid);
+ } # when
- /^deliver / && do {
+ when (/^\s*decrypt\s*$/) {
+ DecryptPassword($parm1, $userid);
+ } # when
+
+ when (/^\s*deliver\s*$/) {
Deliver($parm1);
- last SWITCH
- };
+ } # when
+
+ when (/^\s*add2whitelist\s*$/) {
+ if ($parm2) {
+ $parm2 .= ' ' . $parm3
+ } # if
- /^add2whitelist / && do {
- Add2Whitelist($parm1, GetContext(), $parm2);
- last SWITCH
- };
+ Add2Whitelist(
+ userid => GetContext,
+ type => 'white',
+ sender => $parm1,
+ retention => $parm2,
+ );
+ } # when
- /^showusers / && do {
+ when (/^\s*showusers\s*$/) {
ShowUsers;
- last SWITCH
- };
+ } # when
- /^adduser / && do {
- AddUser($parm1, $parm2, $parm3, $parm4);
- last SWITCH;
- };
+ when (/^\s*adduser\s*$/) {
+ AddUser(
+ userid => $parm1,
+ name => $parm2,
+ email => $parm3,
+ password => Encrypt($parm4, $userid),
+ );
+ } # when
- /^cleanemail / && do {
- if ($parm1 eq '') {
- $parm1 = "9999-12-31 23:59:59";
- } # if
- my $nbr_entries = CleanEmail($parm1);
- print "$nbr_entries email entries cleaned\n";
- last SWITCH;
- };
-
- /^deleteemail / && do {
- my $nbr_entries = DeleteEmail($parm1);
- print "$nbr_entries email entries deleted\n";
- last SWITCH;
- };
-
- /^cleanlog / && do {
- if ($parm1 eq '') {
- $parm1 = "9999-12-31 23:59:59";
- } # if
- my $nbr_entries = CleanLog($parm1);
- print "$nbr_entries log entries cleaned\n";
- last SWITCH;
- };
+ when (/^\s*cleanemail\s*$/) {
+ $parm1 = "9999-12-31 23:59:59" unless $parm1;
- /^loadlist / && do {
+ say CleanEmail($parm1);
+ } # when
+
+ when (/^\s*cleanlog\s*$/) {
+ $parm1 = "9999-12-31 23:59:59" unless $parm1;
+
+ say CleanLog($parm1);
+ } # when
+
+ when (/^\s*loadlist\s*$/) {
LoadListFile($parm1);
- last SWITCH;
- };
+ } # when
- /^loademail / && do {
+ when (/^\s*loademail\s*$/) {
LoadEmail($parm1);
- last SWITCH;
- };
+ } # when
- /^dumpemail / && do {
+ when (/^\s*dumpemail\s*$/) {
DumpEmail($parm1);
- last SWITCH;
- };
-
- /^log / && do {
- Logmsg("info", "$parm1 $parm2", $parm3);
- last SWITCH;
- };
-
- /^switchuser / && do {
+ } # when
+
+ when (/^\s*log\s*$/) {
+ Logmsg(
+ userid => $userid,
+ type => $parm1,
+ sender => $parm2,
+ message => $parm3,
+ );
+ } # when
+
+ when (/^\s*switchuser\s*$/) {
SwitchUser($parm1);
- last SWITCH;
- };
+ } # when
- /^showuser / && do {
+ when (/^\s*showuser\s*$/) {
ShowUser;
- last SWITCH;
- };
+ } # when
- /^showemail / && do {
+ when (/^\s*showemail\s*$/) {
ShowEmail;
- last SWITCH
- };
+ } # when
- /^showlog / && do {
+ when (/^\s*showlog\s*$/) {
ShowLog($parm1);
- last SWITCH
- };
+ } # when
- /^showlist / && do {
+ when (/^\s*showlist\s*$/) {
ShowList($parm1);
- last SWITCH
- };
+ } # when
- /^space / && do {
- ShowSpace($parm1);
- last SWITCH
- };
+ when (/^\s*space\s*$/) {
+ ShowSpace;
+ } # when
- /^showstats / && do {
+ when (/^\s*showstats\s*$/) {
ShowStats($parm1);
- last SWITCH
- };
-
- /^help / && do {
- print "Valid commands are:\n\n";
- print "adduser <userid> <realname> <email> <password>\tAdd user to DB\n";
- print "add2whitelist <sender> <name>\t\tAdd sender to whitelist\n";
- print "cleanlog [timestamp]\t\tCleans out old log entries\n";
- print "log <message>\t\t\tLogs a message\n";
- print "loadlist <listfile>\t\t\tLoad a list file\n";
- print "cleanemail [timestamp]\t\tCleans out old email entries\n";
- print "deliver <message>\t\t\tDelivers a message\n";
- print "loademail <mbox>\t\t\tLoad an mbox file\n";
- print "dumpemail <mbox>\t\t\tDump email from DB to an mbox file\n";
- print "deleteemail <sender>\t\t\tDelete email from sender\n";
- print "switchuser <userid>\t\t\tSwitch to user\n";
- print "showuser\t\t\t\tShow current user\n";
- print "showusers\t\t\t\tShows users in the DB\n";
- print "showemail\t\t\t\tDisplays email\n";
- print "showlog <nbr>\t\t\tDisplays <nbr> log entries\n";
- print "space\t <detail>\t\t\tDisplay space usage\n";
- print "showlist <type>\t\t\tShow list by type\n";
- print "showstats <nbr>\t\t\tDisplays <nbr> days of stats\n";
- print "encrypt <password>\t\t\tEncrypt a password\n";
- print "resequence <list>\t\t\tResequences a list\n";
- print "help\t\t\t\t\tThis screen\n";
- print "exit\t\t\t\t\tExit mapsutil\n";
- last SWITCH;
- };
-
- print "Unknown command: $_";
-
- print " ($parm1" if $parm1;
- print ", $parm2" if $parm2;
- print ", $parm3" if $parm3;
- print ", $parm4" if $parm4;
- print ")\n";
- } # SWITCH
-} # ParseCommand
-
-$maps_username = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
-
-my $username = Login2MAPS($maps_username, $ENV{MAPS_PASSWORD});
+ } # when
+
+ when (/^\s*setpassword\s*$/) {
+ SetPassword;
+ } # when
+
+ default {
+ say "Unknown command: $_";
+
+ say "Parm1: $parm1" if $parm1;
+ say "Parm2: $parm2" if $parm2;
+ say "Parm3: $parm3" if $parm3;
+ say "Parm4: $parm4" if $parm4;
+ } # default
+ } # given
+
+ return;
+} # ExecuteCmd
+
+my $username = Login2MAPS($userid, $ENV{MAPS_PASSWORD});
if ($ARGV[0]) {
- ParseCommand($ARGV[0], $ARGV[1], $ARGV[2], $ARGV[3], $ARGV[4]);
+ ExecuteCmd join ' ', @ARGV;
exit;
} # if
-# Use ReadLine
-my $term = new Term::ReadLine 'mapsutil';
-
-while (1) {
- $_ = $term->readline ("MAPSUtil:");
+# Use CommandLine
+$CmdLine::cmdline->set_cmds(%cmds);
+$CmdLine::cmdline->set_eval(\&ExecuteCmd);
- last unless $_;
+while (my ($line, $result) = $CmdLine::cmdline->get) {
+ next unless $line;
- my ($cmd, $parm1, $parm2, $parm3, $parm4) = split;
+ last if $line =~ /^\s*exit\s*$/i or $line =~ /^\s*quit\s*$/i;
- last if ($cmd =~ /exit/i || $cmd =~ /quit/i);
-
- ParseCommand($cmd, $parm1, $parm2, $parm3, $parm4) if defined $cmd;
+ ExecuteCmd $line;
} # while
-print "\n" unless $_;
-
exit;
# Modified: $Date: 2013/06/12 14:05:47 $
# Language: perl
#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
+# (c) Copyright 2000-2021, Andrew@DeFaria.com, all rights reserved.
#
################################################################################
use strict;
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
# Main
my $i = 0;
-foreach (ReturnSequenceNbrs) {
- UpdateList(
- $userid,
- $type,
- param("pattern$_"),
- param("domain$_"),
- param("comment$_"),
- param("hit_count$_"),
- $_,
+for (ReturnSequenceNbrs) {
+ my %rec = (
+ userid => $userid,
+ type => $type,
+ sequence => $_,
);
+
+ $rec{pattern} = param "pattern$_";
+ $rec{domain} = param "domain$_";
+ $rec{comment} = param "comment$_";
+ $rec{hit_count} = param "hit_count$_";
+ $rec{retention} = param "retention$_";
+
+ $rec{hit_count} = 0 unless $rec{hit_count};
+
+ my ($err, $msg) = UpdateList(%rec);
+
+ croak $msg if $err;
+
$i++;
} # for
-if ($i eq 0) {
+if ($i == 0) {
print redirect ("/maps/php/list.php?type=$type&next=$next&message=Unable to update entries");
-} elsif ($i eq 1) {
+} elsif ($i == 1) {
print redirect ("/maps/php/list.php?type=$type&next=$next&message=Modified entry");
} else {
print redirect ("/maps/php/list.php?type=$type&next=$next&message=Modified entries");
use warnings;
use FindBin;
-$0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
my $count;
- foreach (@sequence_nbrs) {
- $count += DeleteList($type, $_);
- } # foreach
+ for (@sequence_nbrs) {
+ my ($err, $msg) = DeleteList(
+ userid => $userid,
+ type => $type,
+ sequence => $_,
+ );
+
+ # How to best handle error?
+ croak $msg if $err < 0;
+
+ $count += $err;
+ } # for
if ($count == 0) {
DisplayError('Nothing to delete!');
} else {
- ResequenceList($userid, $type);
+ ResequenceList(
+ userid => $userid,
+ type => $type
+ );
if ($count == 1) {
print redirect ("/maps/php/list.php?type=$type&next=$next&message=Deleted entry");
my $email = '';
my $pattern = '';
my $domain = '';
- my $hit_count = 0;
+ my $retention = '';
+ my $hit_count = '';
if (defined $email_nbr && $email_nbr ne '') {
$email = param "email$email_nbr";
-align => 'center'}, "$nextseq",
td {-class => $dataclass,
-align => 'right'},
- (textfield {-class => 'inputfield',
+ (textfield {-class => 'inputfieldright',
-style => 'width:100%',
- -align => 'right',
-size => 25,
-maxlength => '255',
-name => "pattern$nextseq",
td {-class => $dataclass},
(textfield {-class => 'inputfield',
-style => 'width:100%',
- -align => 'left',
-size => 25,
-maxlength => '255',
-name => "domain$nextseq",
-value => $domain}),
td {-class => $dataclass},
- (textfield {-class => 'inputfield',
+ (textfield {-class => 'inputfieldright',
-style => 'width:100%',
- -align => 'left',
-size => 25,
-maxlength => '255',
- -name => "comment$nextseq",
- -value => ''}),
+ -name => "hit_count$nextseq",
+ -value => $hit_count}),
+ td {-class => $dataclass},
+ (textfield {-class => 'inputfieldright',
+ -style => 'width:100%',
+ -size => 20,
+ -maxlength => '40',
+ -name => "retention$nextseq",
+ -value => $retention}),
td {-class => $rightclass},
(textfield {-class => 'inputfield',
-style => 'width:100%',
- -align => 'left',
-size => 25,
-maxlength => '255',
- -name => "hit_count$nextseq",
- -value => $hit_count}),
+ -name => "comment$nextseq",
+ -value => ''}),
];
return;
# empty, editable entries (possibly filled in) for the user to add
# the new entry
my $selected = @selected;
- my $nextseq = GetNextSequenceNo($userid, $type);
+ my $nextseq = GetNextSequenceNo(
+ userid => $userid,
+ type => $type,
+ );
+
my $next = ($nextseq - $lines) + $selected - 1;
- $next = 0
- if $next < 0;
+ $next = 0 if $next < 0;
my $Type = ucfirst $type;
# Now display table and new entry
print start_form {
-method => 'post',
- -action => 'add2' . $type . 'list.cgi',
+ -action => "add2${type}list.cgi",
-name => 'list'
};
th {-class => 'tableheader'}, 'Username',
th {-class => 'tableheader'}, '@',
th {-class => 'tableheader'}, 'Domain',
- th {-class => 'tableheader'}, 'Comments',
- th {-class => 'tablerightend'}, 'Hit Count'
+ th {-class => 'tableheader'}, 'Hit Count',
+ th {-class => 'tableheader'}, 'Retention',
+ th {-class => 'tablerightend'}, 'Comments',
];
- my @list = ReturnList($type, $next, $lines);
- my %record;
+ my $list = ReturnList(
+ userid => $userid,
+ type => $type,
+ start_at => $next,
+ lines => $lines,
+ );
+
my $i = 1;
- for (@list) {
+ for my $record (@$list) {
$i++;
- %record = %{$_};
-
# Normalize fields
- my $sequence = $record{sequence};
- my $pattern = $record{pattern} ? $record{pattern} : ' ';
- my $domain = $record{domain} ? $record{domain} : ' ';
- my $comment = $record{comment} ? $record{comment} : ' ';
- my $hit_count = $record{hit_count} ? $record{hit_count} : ' ';
+ $record->{pattern} //= ' ';
+ $record->{domain} //= ' ';
+ $record->{comment} //= ' ';
+ $record->{hit_count} //= ' ';
+ $record->{retention} //= ' ';
print Tr [
- td {-class => 'tableleftdata',
- -align => 'center'}, $sequence,
- td {-class => 'tabledata',
- -align => 'right'}, $pattern,
- td {-class => 'tabledata',
- -align => 'center'}, '@',
- td {-class => 'tabledata',
- -align => 'left'}, $domain,
- td {-class => 'tabledata',
- -align => 'left'}, $comment,
- td {-class => 'tablerightdata',
- -align => 'right'}, $hit_count,
+ td {-class => 'tableleftdata', -align => 'center'}, $record->{sequence},
+ td {-class => 'tabledata', -align => 'right'}, $record->{pattern},
+ td {-class => 'tabledata', -align => 'center'}, '@',
+ td {-class => 'tabledata', -align => 'left'}, $record->{domain},
+ td {-class => 'tabledata', -align => 'right'}, $record->{hit_count},
+ td {-class => 'tabledata', -align => 'right'}, $record->{retention},
+ td {-class => 'tablerightdata', -align => 'left'}, $record->{comment},
];
} # for
};
# Print some hidden fields to pass along
- print
- hidden ({-name => 'type',
- -default => $type}),
- hidden ({-name => 'next',
- -default => $next});
+ print hidden ({-name => 'type', -default => $type}),
+ hidden ({-name => 'next', -default => $next});
print start_table {-align => 'center',
-id => $table_name,
th {-class => 'tableheader'}, 'Username',
th {-class => 'tableheader'}, '@',
th {-class => 'tableheader'}, 'Domain',
- th {-class => 'tableheader'}, 'Comments',
- th {-class => 'tablerightend'}, 'Hit Count',
+ th {-class => 'tableheader'}, 'Hit Count',
+ th {-class => 'tableheader'}, 'Retention',
+ th {-class => 'tablerightend'}, 'Comments',
];
- # Corner case: If on the first page (i.e. $next=0) then being zero based, we
- # will actually get 21 entries in @list (i.e. $next=0, $lines=20 - 21 $entries
- # are retrieved). So in that case, and that case only, we will change $lines
- # to $lines - 1.
- --$lines if $next == 0;
+ my $list = ReturnList(
+ userid => $userid,
+ type => $type,
+ start_at => $next,
+ lines => $lines,
+ );
- my @list = ReturnList($type, $next, $lines);
- my %record;
my $s = 0;
my $i = 1;
- for (@list) {
- %record = %{$_};
-
- my $sequence = $record{sequence};
- my $leftclass = ($i == @list || $sequence eq $total) ?
+ for my $record (@$list) {
+ my $leftclass = ($i == @$list || $record->{sequence} eq $total) ?
'tablebottomleft' : 'tableleftdata';
- my $dataclass = ($i == @list || $sequence eq $total) ?
+ my $dataclass = ($i == @$list || $record->{sequence} eq $total) ?
'tablebottomdata' : 'tabledata';
- my $rightclass = ($i == @list || $sequence eq $total) ?
+ my $rightclass = ($i == @$list || $record->{sequence} eq $total) ?
'tablebottomright' : 'tablerightdata';
$i++;
print start_Tr,
td {-class => $leftclass,
- -align => 'center'}, $record{sequence};
+ -align => 'center'}, $record->{sequence};
- if ($record{sequence} eq $selected[$s]) {
+ if ($selected[$s] and $record->{sequence} eq $selected[$s]) {
$s++;
# Normalize fields
- my $pattern = $record{pattern} ? $record{pattern} : '';
- my $domain = $record{domain} ? $record{domain} : '';
- my $comment = $record{comment} ? $record{comment} : '';
- my $hit_count = $record{hit_count} ? $record{hit_count} : '';
+ $record->{pattern} //= '';
+ $record->{domain} //= '';
+ $record->{comment} //= '';
+ $record->{hit_count} //= '';
+ $record->{retention} //= '';
print
td {-class => $dataclass,
-align => 'right'},
- (textfield {-class => 'inputfield',
+ (textfield {-class => 'inputfieldright',
-style => 'width:100%',
-align => 'right',
-size => 25,
-maxlength => '255',
- -name => "pattern$sequence",
- -value => $pattern}),
+ -name => "pattern$record->{sequence}",
+ -value => $record->{pattern}}),
td {-class => $dataclass,
-align => 'center'}, '@',
td {-class => $dataclass},
-align => 'left',
-size => 25,
-maxlength => '255',
- -name => "domain$sequence",
- -value => $domain}),
+ -name => "domain$record->{sequence}",
+ -value => $record->{domain}}),
td {-class => $dataclass},
- (textfield {-class => 'inputfield',
+ (textfield {-class => 'inputfieldright',
-style => 'width:100%',
-align => 'left',
-size => 25,
-maxlength => '255',
- -name => "comment$sequence",
- -value => $comment}),
+ -name => "hit_count$record->{sequence}",
+ -value => $record->{hit_count}}),
+ td {-class => $dataclass},
+ (textfield {-class => 'inputfieldright',
+ -style => 'width:100%',
+ -align => 'left',
+ -size => 25,
+ -maxlength => '40',
+ -name => "retention$record->{sequence}",
+ -value => $record->{retention}}),
td {-class => $rightclass},
- (textfield {-class => 'inputfield',
- -style => 'width:100%',
- -align => 'left',
- -size => 25,
- -maxlength => '255',
- -name => "hit_count$sequence",
- -value => $hit_count});
+ (textfield {-class => 'inputfield',
+ -style => 'width:100%',
+ -align => 'left',
+ -size => 25,
+ -maxlength => '255',
+ -name => "comment$record->{sequence}",
+ -value => $record->{comment}});
} else {
+ # Normalize fields
# Put in ' ' for undefined fields
- my $pattern = $record{pattern} ? $record{pattern} : ' ';
- my $domain = $record{domain} ? $record{domain} : ' ';
- my $comment = $record{comment} ? $record{comment} : ' ';
- my $hit_count = $record{hit_count} ? $record{hit_count} : ' ';
+ $record->{pattern} //= ' ';
+ $record->{domain} //= ' ';
+ $record->{comment} //= ' ';
+ $record->{hit_count} //= ' ';
+ $record->{retention} //= ' ';
print
td {-class => $dataclass,
- -align => 'right'}, $pattern,
+ -align => 'right'}, $record->{pattern},
td {-class => $dataclass,
-align => 'center'}, '@',
td {-class => $dataclass,
- -align => 'left'}, $domain,
+ -align => 'left'}, $record->{domain},
td {-class => $dataclass,
- -align => 'left'}, $comment,
+ -align => 'right'}, $record->{hit_count},
+ td {-class => $dataclass,
+ -align => 'right'}, $record->{retention},
td {-class => $rightclass,
- -align => 'left'}, $hit_count;
+ -align => 'left'}, $record->{comment};
} # if
print end_Tr;
sub WhitelistMarked {
AddNewEntry('white', ReturnSequenceNbrs);
+
+ return;
} # WhitelistMarked
sub BlacklistMarked {
AddNewEntry('black', ReturnSequenceNbrs);
+
+ return;
} # BlacklistMarked
sub NulllistMarked {
AddNewEntry('null', ReturnSequenceNbrs);
+
+ return;
} # NulllistMarked
# Main
$lines = $options{'Page'};
-$total = count('list', "userid = \"$userid\" and type = \"$type\"") if $type;
+$total = CountList(
+ userid => $userid,
+ type => $type,
+) if $type;
if ($action eq 'Add') {
AddNewEntry($type);
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
-value => "Close Window",
-onClick => "window.close ()")
);
+
print end_html;
+
+ return;
} # MyFooting
sub MyError($) {
print
h2 ({-class => "header",
-align => "center"},
- font ({-class => "standout"},
- "MAPS"), "Registration Results"
- );
+ 'Registration Results'
+ );
+
+ return;
} # MyHeading
# Main
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use CGI qw/:standard *table start_div end_div/;
]);
print
h2 ({-class => "header", -align => "center"},
- font ({-class => "standout"}, "MAPS"),
- "Mail Authorization and Permission System");
+ "Mail Authorization and Permission System");
if ($errormsg) {
DisplayError $errormsg;
];
print end_table;
print end_div;
+
+ return;
} # Body
if (!$userid) {
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSWeb;
-use MAPSUtil;
+
use CGI qw (:standard *table start_Tr start_td start_div end_Tr end_td end_div);
use CGI::Carp "fatalsToBrowser";
my $str = param('str');
my $next = param('next');
my $lines = param('lines');
-my $userid;
-my $prev;
-my $total;
-my $last;
+
+my ($userid, $prev, $total, $last);
+
my $table_name = 'searchresults';
sub MakeButtons {
} # HighlightSearchStr
sub Body {
- my @emails;
-
- @emails = SearchEmails $userid, $str;
+ my @emails = SearchEmails(
+ userid => $userid,
+ search => $str,
+ );
my $current = $next + 1;
th {-class => "tablerightend"}, "Date"
];
- foreach (@emails) {
- my $sender = shift @{$_};
- my $subject = shift @{$_};
- my $date = shift @{$_};
+ for my $rec (@emails) {
+ my $display_sender = HighlightSearchStr $rec->{sender};
- my $display_sender = HighlightSearchStr $sender;
- $subject = HighlightSearchStr $subject;
- $subject = $subject eq "" ? "<Unspecified>" : $subject;
+ $rec->{subject} //= '<Unspecified>';
+ $rec->{subject} = HighlightSearchStr $rec->{subject};
$next++;
(checkbox {-name => "action$next",
-label => ""}),
hidden ({-name => "email$next",
- -default => $sender}),
+ -default => $rec->{sender}}),
td {-class => "sender"},
- a {-href => "mailto:$sender"}, $display_sender,
+ a {-href => "mailto:$rec->{sender}"}, $display_sender,
td {-class => "subject"},
- a {-href => "display.cgi?sender=$sender"}, $subject,
+ a {-href => "display.cgi?sender=$rec->{sender}"}, $rec->{subject},
td {-class => "dateright",
- -width => "115"}, SQLDatetime2UnixDatetime $date
+ -width => "115"}, SQLDatetime2UnixDatetime $rec->{date},
];
} # foreach
print end_table;
+
+ return;
} # Body
# Main
@scripts
);
+$userid //= $ENV{USER};
+
SetContext $userid;
NavigationBar $userid;
$lines = $options{"Page"};
} # if
-$total = count "email",
- "userid = \"$userid\" and (subject like \"%$str%\" or sender like \"%$str%\")";
+$total = CountEmail(
+ userid => $userid,
+ additional => "(subject like '%$str%' or sender like '%$str%')",
+);
DisplayError "Nothing matching!" if $total eq 0;
-$next = !defined $next ? 0 : $next;
+$next //= 0;
$last = $next + $lines < $total ? $next + $lines : $total;
if (($next - $lines) > 0) {
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
my $days = param('days');
my $dates = param('dates');
my $tag_and_forward = param('tag_and_forward');
-my $message;
sub MyError {
my $errmsg = shift;
MyError 'Passwords do not match';
} # if
- my $status = AddUser($userid, $fullname, $email, $password);
+ my $status = AddUser(
+ userid => $userid,
+ name => $fullname,
+ email => $email,
+ password => $password,
+ );
- if ($status ne 0) {
+ if ($status != 0) {
MyError 'Username already exists';
} # if
'Tag&Forward' => $tag_and_forward,
);
- my $status = AddUserOptions($userid, %options);
+ $status = AddUserOptions($userid, %options);
if ($status == 0) {
print redirect ("/maps/?errormsg=User account \"$userid\" created.<br>You may now login");
} else {
MyError "Unable to add useropts for \"$userid\"";
} # if
+
+ return;
} # Body
Body;
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
use MAPS;
use MAPSLog;
-use MAPSUtil;
use MAPSWeb;
+use DateUtils;
use CGI qw (:standard *table start_Tr end_Tr);
use CGI::Carp 'fatalsToBrowser';
$date = defined $date ? $date : Today2SQLDatetime;
-sub Body {
+sub Body($) {
+ my ($userid) = @_;
+
print start_table ({-align => 'center',
-id => $table_name,
-border => 0,
print th {-class => 'tablerightend'}, 'Total';
- my %dates = GetStats($nbr_days, $date);
+ my %dates = GetStats(
+ userid => $userid,
+ days => $nbr_days,
+ date => $date
+ );
my %totals;
for my $date (sort {$b cmp $a} (keys (%dates))) {
print start_Tr;
print td {-class => 'tablerightleftdata',
- -align => 'center'}, FormatDate $date;
+ -align => 'center'}, FormatDate $date, 1;
my $day_total = 0;
my $grand_total = 0;
print start_Tr;
- print th {-class => 'tablebottomlefttotal'}, 'Totals';
+ print th {-class => 'tablebottomlefttotal'}, 'Totals';
for (@Types) {
- if ($totals{$_} eq 0) {
- print td {-class => 'tablebottomtotal'}, ' ';
+ if ($totals{$_} == 0) {
+ print td {-class => 'tablebottomtotal'}, ' ';
} else {
print td {-class => 'tablebottomtotal',
-align => 'center'},
print end_Tr;
print end_table;
+
+ return;
} # Body
# Main
$table_name
);
+$userid //= $ENV{USER};
+
SetContext($userid);
-if (!$nbr_days) {
+unless ($nbr_days) {
my %options = GetUserOptions $userid;
$nbr_days = $options{Dates};
-} # if
+} # unless
NavigationBar($userid);
-Body;
+Body($userid);
Footing($table_name);
use warnings;
use FindBin;
-$0 = $FindBin::Script;
+
+local $0 = $FindBin::Script;
use lib "$FindBin::Bin/../lib";
use CGI qw (:standard);
-my $userid;
-my $Userid;
-my $fullname = param('fullname');
-my $email = param('email');
-my $old_password = param('old_password');
-my $new_password = param('new_password');
-my $repeated_password = param('repeated_password');
-my $mapspop = param('MAPSPOP');
-my $history = param('history');
-my $days = param('days');
-my $dates = param('dates');
-my $tag_and_forward = param('tag_and_forward');
+my ($userid, $Userid);
+my $name = param 'fullname';
+my $email = param 'email';
+my $old_password = param 'old_password';
+my $new_password = param 'new_password';
+my $repeated_password = param 'repeated_password';
+my $mapspop = param 'MAPSPOP';
+my $history = param 'history';
+my $days = param 'days';
+my $dates = param 'dates';
+my $tag_and_forward = param 'tag_and_forward';
sub Body {
my %options = (
'Tag&Forward' => $tag_and_forward,
);
- if ($old_password && $old_password ne '') {
+ if ($old_password) {
my $dbpassword = UserExists($userid);
my $encrypted_old_password = Encrypt($old_password, $userid);
} # if
} # if
- if (UpdateUser($userid, $fullname, $email, $new_password) != 0) {
+ if ($new_password) {
+ unless ($old_password) {
+ DisplayError "You must provide your old password in order to change it";
+ } else {
+ if ($repeated_password ne $new_password) {
+ DisplayError "Your new password does not match your repeat password";
+ } else {
+ $new_password = Encrypt($new_password, $userid);
+ } # if
+ } # unless
+ } # if
+
+ if (UpdateUser(
+ userid => $userid,
+ name => $name,
+ email => $email,
+ password => $new_password,
+ ) != 0) {
DisplayError "Unable to update user record for user $userid";
} # if
print h2 {-class => 'header',
-align => 'center'},
"${Userid}'s profile has been updated";
+
+ return;
} # Body
$userid = Heading (
'Update Profile',
"Update user's profile",
);
+
+$userid //= $ENV{USER};
+
$Userid = ucfirst $userid;
SetContext($userid);
NavigationBar($userid);
-Body();
-Footing();
+
+Body;
+
+Footing;
+
+exit;
\ No newline at end of file
/* (c) Copyright 2003, Andrew@DeFaria.com, all rights reserved. */
/************************************************************************/
body {
- background-color: #fff;
- background-image: url(/maps/images/Pattern1.gif);
+ background-color: #def;
background-repeat: repeat-y;
- color: black;
+ color: white;
font-family: trebuchet MS, trebuchet, verdana, arial, sans-serif;
font-size: 14px;
margin: 0px;
line-height: 18px;
height: auto;
left: 2px;
+ background-color: #579;
+ color: white;
position: absolute;
top: 5px;
width: 135px;
}
.username {
- color: white;
+ color: yellow;
font-family: veranda, arial;
font-style: bold;
- font-size: 14px;
+ font-size: 16px;
margin-left: 2px;
margin-bottom: 5px;
text-align: center;
}
.menu {
- background-color: #579;
- background-image: url(/maps/images/world.gif);
- border: 2px groove black;
font-family: verdana, geneva, arial, helvetica, sans-serif;
font-size: 14px;
font-weight: bold;
}
.intromenu {
- background-color: #579;
border: 2px groove black;
font-family: verdana, geneva, arial, helvetica, sans-serif;
font-size: 14px;
}
.search {
- background: #4682b4;
- border: 2px groove black;
- color: white;
font-family: veranda, arial;
font: bold;
font-size: 70%;
}
.quickstats {
- background-color: #ffffcc;
- border: 2px groove #336699;
- color: black;
font-size: 10px;
line-height: 10px;
margin: 2px;
width: 125px;
}
-.quickstats a:link {
+.smallnumber a:link {
+ color: yellow;
text-decoration: none;
}
+.smallnumber a:visited {
+ color: white;
+ font-weight: bold;
+ background-color: yellow;
+}
+.smallnumber a:hover {
+ color: yellow;
+ background: blue;
+}
+
.quickstats a:hover {
background: blue;
color: white;
}
.content {
- background: #fff;
+ background: #def;
border: 0.1px solid #fff;
color: black;
font-family: trebuchet MS, trebuchet, verdana, arial, sans-serif;
}
.smalllabel {
- color: #993333;
+ color: white;
font-weight: bold;
line-height: 12px;
font-size: 12px;
}
.smallnumber {
- color: black;
+ color: white;
line-height: 12px;
font-size: 12px;
}
.header {
- color: #000099;
+ color: steelblue;
line-height: 12px;
font-weight: bold;
}
}
.found {
- color: black;
- background: #ffffcc;
+ color: white;
+ background: steelblue;
font-style: italic;
+ font-weight: bold;
}
.error {
}
.inputfield {
- background: #ece9d8;
+ background: #c1dffc;
+ color: Black;
+ font-family: Veranda, Times;
+ font-size: 12px;
+ padding-top: 0px;
+ padding-bottom: 0px;
+}
+
+.inputfieldright {
+ background: #c1dffc;
color: Black;
font-family: Veranda, Times;
font-size: 12px;
padding-top: 0px;
padding-bottom: 0px;
+ text-align: right;
}
#searchfield {
font-size: 95%;
font-weight: normal;
- background: #4693c5;
+ background: #c1dffc;
border: solid 1px #00507d;
border-bottom-color: #007de1;
border-right-color: #007de1;
font-weight: italic;
}
+.todaysActivity {
+ color: yellow;
+}
+
/* Headers */
-h1, h2, h3, h4, h5 {
+h1, h2, h3 {
color: #000099;
}
+h4 {
+ color: yellow;
+ font-weight: bold;
+}
+
h1 {
font-size: 18pt;
}
/* Table colors */
.tableleftend {
- background: #804000;
+ background: SteelBlue;
color: white;
font-style: bold;
font-size: 14;
}
.tablerightend {
- background: #804000;
+ background: SteelBlue;
color: white;
font-style: bold;
font-size: 14;
}
.tablebordertopleft {
- background: #804000;
+ background: SteelBlue;
color: white;
font-style: bold;
font-size: 14;
}
.tablebordertopright {
- background: #804000;
+ background: SteelBlue;
color: white;
font-style: bold;
font-size: 14;
}
.tableborderbottomleft {
- background: #804000;
+ background: SteelBlue;
color: white;
font-style: bold;
font-size: 14;
}
.tableborderbottomright {
- background: #804000;
+ background: SteelBlue;
color: white;
font-style: bold;
font-size: 14;
}
.tableborder {
- background: #804000;
+ background: SteelBlue;
color: white;
font-style: bold;
font-size: 14;
}
.tablelabel {
- background: #ece9d8;
+ background: White;
text-align: right;
font-family: arial, sans-serif;
font-size: 10px;
}
.tableheader {
- background: #804000;
+ background: SteelBlue;
color: white;
text-align: center;
font-family: arial, sans-serif;
}
.tableleftdata {
- background: #ffffee;
- border-left: solid 3px #804000;
+ background: White;
+ color: Red;
+ border-left: solid 3px SteelBlue;
border-bottom: 1px dotted #ccc;
font-size: 14;
}
.tableleftrightdata {
- background: #ece9d8;
- border-right: solid 3px #804000;
- border-left: solid 1px #804000;
+ background: #c1dffc;
+ border-right: solid 3px SteelBlue;
+ border-left: solid 1px SteelBlue;
border-bottom: 1px dotted #ccc;
font-size: 14;
}
.tablerightleftdata {
- background: #ece9d8;
- border-right: solid 1px #804000;
- border-left: solid 3px #804000;
+ background: #c1dffc;
+ border-right: solid 1px SteelBlue;
+ border-left: solid 3px SteelBlue;
border-bottom: 1px dotted #ccc;
font-size: 14;
}
.tablerightdata {
- background: #ffffee;
- border-right: solid 3px #804000;
+ background: White;
+ border-right: solid 3px SteelBlue;
border-left: 1px dotted #ccc;
border-bottom: 1px dotted #ccc;
font-size: 14;
}
.tablebottomleft {
- background: #ffffee;
- border-left: solid 3px #804000;
+ background: White;
+ color: Red;
+ border-left: solid 3px SteelBlue;
border-right: 1px dotted #ccc;
- border-bottom: solid 3px #804000;
+ border-bottom: solid 3px SteelBlue;
font-size: 14;
-moz-border-radius-bottomleft: 7px;
border-bottom-left-radius: 7px;
}
.tablebottomright {
- background: #ffffee;
- border-right: solid 3px #804000;
+ background: White;
+ border-right: solid 3px SteelBlue;
border-left: 1px dotted #ccc;
- border-bottom: solid 3px #804000;
+ border-bottom: solid 3px SteelBlue;
font-size: 14;
-moz-border-radius-bottomright: 7px;
border-bottom-right-radius: 7px;
}
.tablebottomdata {
- background: #ffffee;
+ background: White;
border-left: 1px dotted #ccc;
- border-bottom: solid 3px #804000;
+ border-bottom: solid 3px SteelBlue;
font-size: 14;
}
.tablebottomlefttotal {
- background: #ece9d8;
- border-left: solid 3px #804000;
- border-bottom: solid 3px #804000;
+ background: #c1dffc;
+ border-left: solid 3px SteelBlue;
+ border-bottom: solid 3px SteelBlue;
border-right: 1px dotted #ccc;
font-size: 14;
-moz-border-radius-bottomleft: 7px;
border-bottom-left-radius: 7px;
}
.tablebottomrighttotal {
- background: #ece9d8;
- border-right: solid 3px #804000;
- border-bottom: solid 3px #804000;
+ background: #c1dffc;
+ border-right: solid 3px SteelBlue;
+ border-bottom: solid 3px SteelBlue;
font-size: 14;
-moz-border-radius-bottomright: 7px;
border-bottom-right-radius: 7px;
}
.tablebottomtotal {
- background: #ece9d8;
- border-bottom: solid 3px #804000;
- border-top: solid 1px #804000;
+ background: #c1dffc;
+ border-bottom: solid 3px SteelBlue;
+ border-top: solid 1px SteelBlue;
border-right: 1px dotted #ccc;
font-size: 14;
}
.tabledata {
- background: #ffffee;
+ background: White;
border-left: 1px dotted #ccc;
border-bottom: 1px dotted #ccc;
font-size: 14;
}
-
.date {
- background: #ffffee;
+ background: White;
font-size: 10px;
}
.dateright {
- background: #ffffee;
+ background: White;
font-size: 10px;
- border-right: solid 3px #804000;
+ border-right: solid 3px SteelBlue;
border-left: 1px dotted #ccc;
border-bottom: 1px dotted #ccc;
}
/* Special anchor effects */
.sender {
- background: #ffffee;
+ background: White;
font-family: arial, sans-serif;
font-size: 12px;
font-weight: bold;
}
.subject {
- background: #ffffee;
+ background: White;
font-family: arial, sans-serif;
font-size: 10px;
font-weight: bold;
-<?php \r
+<?php\r
include "site-functions.php";\r
include "MAPS.php"\r
?>\r
<body>\r
\r
<div class="heading">\r
- <h2 class="header" align="center">\r
- <font class="standout">MAPS</font> Requirements</h2>\r
+ <h2 class="header" align="center">Requirements</h2>\r
</div>\r
\r
<div class="content">\r
- <?php \r
+ <?php\r
OpenDB ();\r
SetContext ($userid);\r
NavigationBar ($userid);\r
-<?php \r
+<?php\r
include "site-functions.php";\r
include "MAPS.php"\r
?>\r
<body>\r
\r
<div class="heading">\r
- <h2 class="header" align="center">\r
- <font class="standout">MAPS</font> What is SPAM?</h2>\r
+ <h2 class="header" align="center">What is SPAM?</h2>\r
</div>\r
\r
<div class="content">\r
- <?php \r
+ <?php\r
OpenDB ();\r
SetContext ($userid);\r
NavigationBar ($userid);\r
-<?php \r
+<?php\r
include "site-functions.php";\r
include "MAPS.php"\r
?>\r
<body>\r
\r
<div class="heading">\r
- <h2 class="header" align="center">\r
- <font class="standout">MAPS</font> Using</h2>\r
+ <h2 class="header" align="center">Using</h2>\r
</div>\r
\r
<div class="content">\r
- <?php \r
+ <?php\r
OpenDB ();\r
SetContext ($userid);\r
NavigationBar ($userid);\r
+++ /dev/null
-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\r
-<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">\r
-<head>\r
- <title>MAPS Add to Black List</title>\r
- \r
- <link rev="made" href="mailto:Andrew%40DeFaria.com">\r
- \r
- <script language="JavaScript1.2" src="checkform.js"\r
- type="text/javascript"></script>\r
-</head>\r
- <body link="#0000ee" alink="#ff0000" vlink="#cc33cc" bgcolor="#33ccff">\r
- \r
-<h2 align="center">MAPS: Add to Black List<br>\r
- </h2>\r
- This screen allows you to add to your black list. Note that regular expressions\r
- can be used so you can modify the <b>Email address</b> below to be any\r
-portion thereof or specify a regular expression. Here are some examples.\r
-Given an email address of Spammer@spamdomain.com you can:<br>\r
- \r
-<ul>\r
- <li>Specify just the domain (e.g. @spamdomain.com). This will effectively\r
- black list everybody from that domain.</li>\r
- <li>Specify just the username portion (e.g. Spammer@). This will effectively\r
- black list anybody using the username of spammer (note that email addresses\r
-are <b>not</b> case sensitive) from any domain.</li>\r
- <li>Use regular expression characters to further refine your filter.\r
- For example, "^spammer.*@" means any email address that starts (^) with\r
-the word "spammer", has any number of characters after (.*), then an "@"\r
-sign will be black listed.</li>\r
- \r
-</ul>\r
- \r
-<table cellpadding="2" cellspacing="0" border="0" width="50%"\r
- align="center" bgcolor="Red">\r
- <tbody>\r
- <tr>\r
- <td valign="top"> \r
- <table cellpadding="2" cellspacing="0" border="0" width="100%"\r
- rules="rows" bgcolor="White">\r
- <tbody>\r
- <tr align="center">\r
- <th valign="top" bgcolor="#ff0000"><big><font\r
- color="#ffffff">Warning</font></big><br>\r
- </th>\r
- </tr>\r
- <tr>\r
- <td valign="top"><small>Care should be taken when using regular\r
- expressions as you can easily black list email messages you do not want\r
-to have blacklisted</small>!<br>\r
- </td>\r
- </tr>\r
- \r
- </tbody> \r
- </table>\r
- </td>\r
- </tr>\r
- \r
- </tbody> \r
-</table>\r
- <br>\r
- \r
-<form method="post" action="/maps/bin/register.cgi"\r
- enctype="application/x-www-form-urlencoded"\r
- onsubmit="return validate (this);"> \r
- <table border="0" cellspacing="0" cellpadding="2" width="57%"\r
- bgcolor="black" align="center">\r
- <tbody>\r
- <tr>\r
- <td> \r
- <table cellpadding="5" cellspacing="0" border="0" width="100%"\r
- bgcolor="#ffffcc" cols="2">\r
- <tbody>\r
- <tr>\r
- <td><b>Full name</b> </td>\r
- <td align="right"><input type="text" name="realname"\r
- value="" size="50" maxlength="50"> </td>\r
- </tr>\r
- <tr>\r
- <td><b>Email address</b><br>\r
- </td>\r
- <td align="right"><input type="text" name="email" value=""\r
- size="50" maxlength="50"> </td>\r
- </tr>\r
- \r
- </tbody> \r
- \r
- </table>\r
- </td>\r
- </tr>\r
- \r
- </tbody> \r
- </table>\r
- \r
- <center> <input type="submit" name="submit" value="Submit"> </center>\r
- </form>\r
- <br>\r
- <br>\r
-</body>\r
-</html>\r
<body>\r
\r
<div class="heading">\r
- <h2 class="header" align="center">\r
- <font class="standout">MAPS</font> Spam Elimination System!</h2>\r
+ <h2 class="header" align="center">Spam Elimination System!</h2>\r
</div>\r
\r
<div class="content">\r
-<?php \r
+<?php\r
include "site-functions.php";\r
include "MAPS.php";\r
\r
-$logout = $_REQUEST[logout];\r
+$logout = $_REQUEST[logout];\r
+$errormsg = $_REQUEST[errormsg];\r
\r
if (isset ($logout)) {\r
setcookie ("MAPSUser", "", time()+60*60*24*30, "/maps");\r
<body>\r
\r
<div class="heading">\r
- <h2 class="header" align="center">\r
- <font class="standout">MAPS</font> Mail Authorization and Permission System</h2>\r
+ <h2 class="header" align="center">Mail Authorization and Permission System</h2>\r
<h3 class="header" align="center">Spam Elimination System</h3>\r
</div>\r
\r
<div class="content">\r
<?php\r
- OpenDB ();\r
+ OpenDB();\r
NavigationBar ("");\r
?>\r
\r
\r
<form method="post" action="php/main.php"\r
enctype="application/x-www-form-urlencoded">\r
- \r
- <table cellpadding="2" bgcolor="white" width="40%" cellspacing="0" \r
+\r
+ <table cellpadding="2" bgcolor="white" width="40%" cellspacing="0"\r
border="0" align="center">\r
\r
<tr>\r
use DBI;
use Carp;
use FindBin;
-use vars qw(@ISA @EXPORT);
use Exporter;
use MAPSLog;
-use MAPSFile;
-use MAPSUtil;
use MIME::Entity;
+use Display;
+use MyDB;
+use Utils;
+use DateUtils;
+
+use base qw(Exporter);
+
+our $db;
+
+our $Version = '2.0';
+
# Globals
my $userid = $ENV{MAPS_USERNAME} ? $ENV{MAPS_USERNAME} : $ENV{USER};
my %useropts;
-my $DB;
-@ISA = qw(Exporter);
-
-@EXPORT = qw(
+our @EXPORT = qw(
Add2Blacklist
Add2Nulllist
Add2Whitelist
AddUser
AddUserOptions
Blacklist
+ CheckEmail
CleanEmail
CleanLog
CleanList
- CountMsg
+ CountEmail
+ CountList
+ CountLog
Decrypt
DeleteEmail
DeleteList
- DeleteLog
Encrypt
FindEmail
FindList
FindLog
FindUser
+ FindUsers
ForwardMsg
GetContext
GetEmail
ReadMsg
ResequenceList
ReturnList
- ReturnListEntry
ReturnMsg
ReturnMessages
ReturnSenders
UpdateUserOptions
UserExists
Whitelist
- count
- countlog
- count_distinct
);
my $mapsbase = "$FindBin::Bin/..";
-sub Add2Blacklist($$$) {
- # Add2Blacklist will add an entry to the blacklist
- my ($sender, $userid, $comment) = @_;
+# Insternal routines
+sub _cleanTables($$;$) {
+ my ($table, $timestamp, $dryrun) = @_;
+
+ my $count = 0;
+ my $msg = 'Records deleted';
+ my $condition = "userid = '$userid' and timestamp < '$timestamp'";
+
+ if ($dryrun) {
+ return $db->count($table, $condition);
+ } else {
+ return $db->delete($table, $condition);
+ } # if
+} # _cleanTables
+
+sub _retention2Days($) {
+ my ($retention) = @_;
+
+ # Of the retnetion periods I'm thinking of where they are <n> and then
+ # something like (days|weeks|months|years) none are tricky except for months
+ # because months, unlike (days|weeks|years) are ill-defined. Are there 28, 29
+ # 30 or 31 days in a month? Days are simple <n> days. Weeks are simple <n> * 7
+ # days. Years are simple - just change the year (a little oddity of 365 or
+ # 366) days this year? To keep things simple, we will ignore the oddities of
+ # leap years and just use 30 for number of days in month. We really don't need
+ # to be that accurate here...
+ #
+ # BTW we aren't checking for odd things like 34320 weeks or 5000 years...
+ if ($retention =~ /(\d+)\s+(day|days)/) {
+ return $1;
+ } elsif ($retention =~ /(\d+)\s+(week|weeks)/){
+ return $1 * 7;
+ } elsif ($retention =~ /(\d+)\s+(month|months)/) {
+ return $1 * 30;
+ } elsif ($retention =~ /(\d+)\s+(year|years)/) {
+ return $1 * 365;
+ } # if
+} # _retention2Days
+
+sub _getnext() {
+ return $db->getnext;
+} # _getnext
+
+sub OpenDB($$) {
+ my ($username, $password) = @_;
+
+ my $dbname = 'MAPS';
+ my $dbserver = $ENV{MAPS_SERVER} || 'localhost';
+
+ $db = MyDB->new($username, $password, $dbname, $dbserver);
+
+ croak "Unable to instantiate MyDB ($username\@$dbserver:$dbname)" unless $db;
+} # OpenDB
+
+BEGIN {
+ my $MAPS_username = "maps";
+ my $MAPS_password = "spam";
+ OpenDB($MAPS_username, $MAPS_password);
+} # BEGIN
+
+sub Add2Blacklist(%) {
+ my (%params) = @_;
+
+ # Add2Blacklist will add an entry to the blacklist
# First SetContext to the userid whose black list we are adding to
- SetContext($userid);
+ SetContext($params{userid});
# Add to black list
- AddList("black", $sender, 0, $comment);
+ $params{sequence} = 0;
+ my ($err, $msg) = AddList(%params);
# Log that we black listed the sender
- Info("Added $sender to " . ucfirst $userid . "'s black list");
+ Info("Added $params{sender} to " . ucfirst $params{userid} . "'s black list");
# Delete old emails
- my $count = DeleteEmail($sender);
+ my $count = DeleteEmail(
+ userid => $params{userid},
+ sender => $params{sender},
+ );
# Log out many emails we managed to remove
- Info("Removed $count emails from $sender");
+ Info("Removed $count emails from $params{sender}");
- return;
+ return $count;
} # Add2Blacklist
-sub Add2Nulllist($$;$$) {
- # Add2Nulllist will add an entry to the nulllist
- my ($sender, $userid, $comment, $hit_count) = @_;
+sub Add2Nulllist(%) {
+ my (%params) = @_;
# First SetContext to the userid whose null list we are adding to
- SetContext($userid);
+ SetContext($params{userid});
# Add to null list
- AddList("null", $sender, 0, $comment, $hit_count);
+ $params{sequence} = 0;
+ my ($err, $msg) = AddList(%params);
# Log that we null listed the sender
- Info("Added $sender to " . ucfirst $userid . "'s null list");
+ Info("Added $params{sender} to " . ucfirst $params{userid }. "'s null list");
# Delete old emails
- my $count = DeleteEmail($sender);
+ my $count = DeleteEmail(
+ userid => $params{userid},
+ sender => $params{sender},
+ );
# Log out many emails we managed to remove
- Info("Removed $count emails from $sender");
+ Info("Removed $count emails from $params{sender}");
return;
} # Add2Nulllist
-sub Add2Whitelist($$;$) {
- # Add2Whitelist will add an entry to the whitelist
- my ($sender, $userid, $comment) = @_;
+sub Add2Whitelist(%) {
+ my (%params) = @_;
+ # Add2Whitelist will add an entry to the whitelist
# First SetContext to the userid whose white list we are adding to
- SetContext($userid);
+ SetContext($params{userid});
# Add to white list
- AddList('white', $sender, 0, $comment);
+ $params{sequence} = 0;
+ my ($err, $msg) = AddList(%params);
+
+ return -$err, $msg if $err;
# Log that we registered a user
- Logmsg("registered", $sender, "Registered new sender");
+ Logmsg(
+ userid => $params{userid},
+ type => 'registered',
+ sender => $params{sender},
+ message => 'Registered new sender',
+ );
# Check to see if there are any old messages to deliver
- my $handle = FindEmail($sender);
+ ($err, $msg) = $db->find('email', "sender = '$params{sender}'", ['userid', 'sender', 'data']);
- my ($dbsender, $subject, $timestamp, $message);
+ return ($err, $msg) if $err;
# Deliver old emails
- my $messages = 0;
- my $return_status = 0;
+ my $messages = 0;
+ my $status = 0;
- while (($userid, $dbsender, $subject, $timestamp, $message) = GetEmail($handle)) {
- last unless $userid;
+ while (my $rec = $db->getnext) {
+ last unless $rec->{userid};
- $return_status = Whitelist($sender, $message);
+ $status = Whitelist($rec->{sender}, $rec->data);
- last if $return_status;
+ last if $status;
$messages++;
} # while
- # Done with $handle
- $handle->finish;
-
# Return if we has a problem delivering email
- return $return_status if $return_status;
+ return -1, 'Problem delivering some email' if $status;
- # Remove delivered messages.
- DeleteEmail($sender);
+ # Remove delivered messages
+ DeleteEmail(
+ userid => $params{userid},
+ sender => $params{sender},
+ );
- return $messages;
+ return $messages, 'Messages delivered';
} # Add2Whitelist
-sub AddEmail($$$) {
- my ($sender, $subject, $data) = @_;
-
- # "Sanitize" some fields so that characters that are illegal to SQL are escaped
- $sender = 'Unknown' if (!defined $sender || $sender eq '');
- $sender = $DB->quote($sender);
- $subject = $DB->quote($subject);
- $data = $DB->quote($data);
+sub AddEmail(%) {
+ my (%rec) = @_;
- my $timestamp = UnixDatetime2SQLDatetime(scalar(localtime));
- my $statement = "insert into email values (\"$userid\", $sender, $subject, \"$timestamp\", $data)";
+ CheckParms(['userid', 'sender', 'subject', 'data'], \%rec);
- $DB->do ($statement)
- or DBError('AddEmail: Unable to do statement', $statement);
+ $rec{timestamp} = UnixDatetime2SQLDatetime(scalar(localtime));
- return;
+ return $db->add('email', %rec);
} # AddEmail
-sub AddList($$$;$$$) {
- my ($listtype, $pattern, $sequence, $comment, $hit_count, $last_hit) = @_;
-
- $hit_count //= CountMsg($pattern);
+sub AddList(%) {
+ my (%rec) = @_;
- my ($user, $domain) = split /\@/, $pattern;
+ CheckParms(['userid', 'type', 'sender', 'sequence'], \%rec);
- if (!$domain || $domain eq '') {
- $domain = 'NULL';
- $pattern = $DB->quote($user);
- } else {
- $domain = "'$domain'";
+ croak "Type $rec{type} not valid. Must be one of white, black or null"
+ unless $rec{type} =~ /(white|black|null)/;
- if ($user eq '') {
- $pattern = 'NULL';
- } else {
- $pattern = $DB->quote($user);
- } # if
- } # if
+ croak "Sender must contain \@" unless $rec{sender} =~ /\@/;
- if (!$comment || $comment eq '') {
- $comment = 'NULL';
- } else {
- $comment = $DB->quote($comment);
- } # if
+ $rec{retention} //= '';
+ $rec{retention} = lc $rec{retention};
- # Get next sequence #
- if ($sequence == 0) {
- $sequence = GetNextSequenceNo($userid, $listtype);
- } # if
+ $rec{hit_count} //= $db->count(
+ 'email',
+ "userid = '$rec{userid}' and sender like '$rec{sender}%'"
+ );
- $last_hit //= UnixDatetime2SQLDatetime(scalar (localtime));
+ ($rec{pattern}, $rec{domain}) = split /\@/, delete $rec{sender};
- my $statement = "insert into list values (\"$userid\", \"$listtype\", $pattern, $domain, $comment, $sequence, $hit_count, \"$last_hit\")";
+ $rec{sequence} = GetNextSequenceNo(%rec);
- $DB->do($statement)
- or DBError('AddList: Unable to do statement', $statement);
+ $rec{last_hit} //= UnixDatetime2SQLDatetime(scalar (localtime));
- return;
+ return $db->add('list', %rec);
} # AddList
-sub AddLog ($$$) {
- my ($type, $sender, $msg) = @_;
+sub AddLog(%) {
+ my (%params) = @_;
my $timestamp = UnixDatetime2SQLDatetime(scalar(localtime));
- my $statement;
- # Use quote to protect ourselves
- $msg = $DB->quote($msg);
+ return $db->add('log', %params);
+} # AddLog
- if ($sender eq '') {
- $statement = "insert into log values (\"$userid\", \"$timestamp\", null, \"$type\", $msg)";
- } else {
- $statement = "insert into log values (\"$userid\", \"$timestamp\", \"$sender\", \"$type\", $msg)";
- } # if
+sub AddUser(%) {
+ my (%rec) = @_;
- $DB->do($statement)
- or DBError('AddLog: Unable to do statement', $statement);
+ CheckParms(['userid', 'name', 'email', 'password'], \%rec);
- return;
-} # AddLog
+ return 1 if UserExists($rec{userid});
-sub AddUser($$$$) {
- my ($userid, $realname, $email, $password) = @_;
+ return $db->add('user', %rec);
+} # Adduser
- $password = Encrypt($password, $userid);
+sub AddUserOptions(%) {
+ my (%rec) = @_;
- if (UserExists($userid)) {
- return 1;
- } else {
- my $statement = "insert into user values ('$userid', '$realname', '$email', '$password')";
+ croak('Userid is required') unless $rec{userid};
+ croak('No options to add') unless $rec{options};
- $DB->do($statement)
- or DBError('AddUser: Unable to do statement', $statement);
- } # if
+ return (1, "User doesn't exists") unless UserExist($rec{userid});
- return 0;
-} # Adduser
+ my %useropts = delete $rec{userid};
+ my %opts = delete $rec{options};
-sub AddUserOptions($%) {
- my ($userid, %options) = @_;
+ my ($err, $msg);
- for (keys %options) {
- return 1 if !UserExists($userid);
+ for my $key (%opts) {
+ $useropts{name} = $_;
+ $useropts{value} = $opts{$_};
- my $statement = "insert into useropts values ('$userid', '$_', '$options{$_}')";
+ ($err, $msg) = $db->add('useropts', %useropts);
- $DB->do($statement)
- or DBError('AddUserOption: Unable to do statement', $statement);
+ last if $err;
} # for
- return 0;
+ return ($err, $msg) if $err;
} # AddUserOptions
-sub Blacklist($%) {
+sub Blacklist(%) {
# Blacklist will send a message back to the $sender telling them that
# they've been blacklisted. Currently we save a copy of the message.
# In the future we should just disregard the message.
- my ($sender, $sequence, $hit_count, @msg) = @_;
+ my (%rec) = @_;
# Check to see if this sender has already emailed us.
- my $msg_count = CountMsg($sender);
+ my $msg_count = $db->count('email', "userid='$rec{userid}' and sender like '%$rec{sender}%'");
if ($msg_count < 5) {
# Bounce email
- SendMsg($sender, "Your email has been discarded by MAPS", "$mapsbase/blacklist.html", @msg);
- Logmsg("blacklist", $sender, "Sent blacklist reply");
+ my @spammsg = split "\n", $rec{data};
+
+ SendMsg(
+ userid => $rec{userid},
+ sender => $rec{sender},
+ subject => 'Your email has been discarded by MAPS',
+ msgfile => "$mapsbase/blacklist.html",
+ data => $rec{data},
+ );
+
+ Logmsg(
+ userid => $userid,
+ type => 'blacklist',
+ sender => $rec{sender},
+ message => 'Sent blacklist reply',
+ );
} else {
- Logmsg("mailloop", $sender, "Mail loop encountered");
+ Logmsg(
+ userid => $userid,
+ type => 'mailloop',
+ sender => $rec{sender},
+ message => 'Mail loop encountered',
+ );
} # if
- RecordHit("black", $sequence, ++$hit_count) if $sequence;
+ $rec{hit_count}++ if $rec{sequence};
+
+ RecordHit(
+ userid => $userid,
+ type => 'black',
+ sequence => $rec{sequence},
+ hit_count => $rec{hit_count},
+ );
return;
} # Blacklist
+sub CheckEmail(;$$) {
+ my ($username, $domain) = @_;
+
+ return lc "$username\@$domain" if $username and $domain;
+
+ # Check to see if a full email address in either $username or $domain
+ if ($username) {
+ if ($username =~ /(.*)\@(.*)/) {
+ return lc "$1\@$2";
+ } # if
+ } elsif ($domain) {
+ if ($domain =~ /(.*)\@(.*)/) {
+ return lc "$1\@$2";
+ } else {
+ return "\@$domain";
+ } # if
+ } # if
+} # CheckEmail
+
sub CheckOnList ($$;$) {
- # CheckOnList will check to see if the $sender is on the $listfile.
- # Return 1 if found 0 if not.
+ # CheckOnList will check to see if the $sender is on the list. Return 1 if
+ # found 0 if not.
my ($listtype, $sender, $update) = @_;
$update //= 1;
my $status = 0;
- my ($rule, $sequence, $hit_count);
-
- my $statement = 'select pattern, domain, comment, sequence, hit_count '
- . "from list where userid = '$userid' and type = '$listtype' "
- . 'order by sequence';
+ my ($rule, $sequence);
- my $sth = $DB->prepare($statement)
- or DBError('CheckOnList: Unable to prepare statement', $statement);
+ my $table = 'list';
+ my $condition = "userid='$userid' and type='$listtype'";
- $sth->execute
- or DBError('CheckOnList: Unable to execute statement', $statement);
+ my ($err, $errmsg) = $db->find($table, $condition, '*', 'order by sequence');
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
+ my ($email_on_file, $rec);
- $hit_count = pop (@row);
- $sequence = pop (@row);
- my $comment = pop (@row);
- my $domain = pop (@row);
- my $pattern = pop (@row);
- my $email_on_file;
-
- unless ($domain) {
- $email_on_file = $pattern;
+ while ($rec = $db->getnext) {
+ unless ($rec->{domain}) {
+ $email_on_file = $rec->{pattern};
} else {
- unless ($pattern) {
- $email_on_file = '@' . $domain;
+ unless ($rec->{pattern}) {
+ $email_on_file = '@' . $rec->{domain};
} else {
- $email_on_file = $pattern . '@' . $domain;
+ $email_on_file = $rec->{pattern} . '@' . $rec->{domain};
} # if
} # unless
# "@ti.com" would also match "@tixcom.com"!
my $search_for = $email_on_file =~ /\@/
? "$email_on_file\$"
- : !defined $domain
+ : !defined $rec->{domain}
? "$email_on_file\@"
: $email_on_file;
if ($sender and $sender =~ /$search_for/i) {
- $rule = "Matching rule: ($listtype:$sequence) \"$email_on_file\"";
- $rule .= " - $comment" if $comment and $comment ne '';
+ $rule = "Matching rule: ($listtype:$rec->{sequence}) \"$email_on_file\"";
+ $rule .= " - $rec->{comment}" if $rec->{comment};
$status = 1;
- RecordHit($listtype, $sequence, ++$hit_count) if $update;
+ $rec->{hit_count} //= 0;
+
+ RecordHit(
+ userid => $userid,
+ type => $listtype,
+ sequence => $rec->{sequence},
+ hit_count => $rec->{hit_count} + 1,
+ ) if $update;
last;
} # if
} # while
- $sth->finish;
-
- return ($status, $rule, $sequence, $hit_count);
+ return ($status, $rule, $rec->{sequence}, $rec->{hit_count});
} # CheckOnList
-sub CleanEmail($) {
- my ($timestamp) = @_;
-
- # First see if anything needs to be deleted
- my $count = 0;
-
- my $statement = "select count(*) from email where userid = '$userid' and timestamp < '$timestamp'";
+sub CleanEmail($;$) {
+ my ($timestamp, $dryrun) = @_;
- # Prepare statement
- my $sth = $DB->prepare($statement)
- or DBError('CleanEmail: Unable to prepare statement', $statement);
-
- # Execute statement
- $sth->execute
- or DBError('CleanEmail: Unable to execute statement', $statement);
-
- # Get return value, which should be how many entries were deleted
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- # Retrieve returned value
- unless ($row[0]) {
- $count = 0
- } else {
- $count = $row[0];
- } # unless
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- # Delete emails for userid whose older than $timestamp
- $statement = "delete from email where userid = '$userid' and timestamp < '$timestamp'";
-
- # Prepare statement
- $sth = $DB->prepare($statement)
- or DBError('CleanEmail: Unable to prepare statement', $statement);
-
- # Execute statement
- $sth->execute
- or DBError('CleanEmail: Unable to execute statement', $statement);
-
- return $count;
+ return _cleanTables 'email', $timestamp, $dryrun;
} # ClearEmail
-sub CleanLog($) {
- my ($timestamp) = @_;
+sub CleanLog($;$) {
+ my ($timestamp, $dryrun) = @_;
- # First see if anything needs to be deleted
- my $count = 0;
-
- my $statement = "select count(*) from log where userid = '$userid' and timestamp < '$timestamp'";
-
- # Prepare statement
- my $sth = $DB->prepare($statement)
- or DBError($DB, 'CleanLog: Unable to prepare statement', $statement);
-
- # Execute statement
- $sth->execute
- or DBError('CleanLog: Unable to execute statement', $statement);
-
- # Get return value, which should be how many entries were deleted
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- # Retrieve returned value
- unless ($row[0]) {
- $count = 0
- } else {
- $count = $row[0];
- } # unless
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- # Delete log entries for userid whose older than $timestamp
- $statement = "delete from log where userid = '$userid' and timestamp < '$timestamp'";
-
- # Prepare statement
- $sth = $DB->prepare($statement)
- or DBError('CleanLog: Unable to prepare statement', $statement);
-
- # Execute statement
- $sth->execute
- or DBError('CleanLog: Unable to execute statement', $statement);
-
- return $count;
+ return _cleanTables('log', $timestamp, $dryrun);
} # CleanLog
-sub CleanList($;$) {
- my ($timestamp, $listtype) = @_;
+sub CleanList(%) {
+ my (%params) = @_;
+
+ CheckParms(['userid', 'type'], \%params);
+
+ my $dryrunstr = $params{dryrun} ? '(dryrun)' : '';
+
+ my $table = 'list';
+ my $condition = "userid='$params{userid}' and type='$params{type}'";
+ my $count = 0;
+
+ # First let's go through the list to see if we have an domain level entry
+ # (e.g. @spammer.com) and also individual entries (baddude@spammer.com) then
+ # we don't really need any of the individual entries since the domain block
+ # covers them.
+ $db->find($table, $condition, ['domain'], ' and pattern is null');
+
+ while (my $domains = $db->getnext) {
+ for my $recs ($db->get($table, $condition, ['sequence', 'pattern', 'domain'],
+ " and domain='$domains->{domain}' and pattern is not null")) {
+ if (@$recs and not $params{dryrun}) {
+ for my $rec (@$recs) {
+ DeleteList(
+ userid => $params{userid},
+ type => $params{type},
+ sequence => $rec->{sequence},
+ );
+
+ $params{log}->msg("Deleted $params{userid}:$params{type}:$rec->{sequence} "
+ . "$rec->{pattern}\@$rec->{domain} $dryrunstr")
+ if $params{log};
+
+ $count++;
+ } # for
+ } elsif (@$recs) {
+ if ($params{log}) {
+ $params{log}->msg("The domain $domains->{domain} has the following subrecords");
+
+ for my $rec (@$recs) {
+ $params{log}->msg("$rec->{pattern}\@$rec->{domain}");
+ } # for
+ } # if
+ } # if
+ } # for
+ } # while
- $listtype //= 'null';
+ my $msg = 'Records deleted';
+ $condition = "userid='$params{userid}' and type='$params{type}' and retention is not null";
# First see if anything needs to be deleted
- my $count = 0;
-
- my $statement = "select count(*) from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
-
- # Prepare statement
- my $sth = $DB->prepare($statement)
- or DBError($DB, 'CleanList: Unable to prepare statement', $statement);
+ return (0, $msg) unless $db->count($table, $condition);
- # Execute statement
- $sth->execute
- or DBError('CleanList: Unable to execute statement', $statement);
+ my ($err, $errmsg) = $db->find($table, $condition);
- # Get return value, which should be how many entries were deleted
- my @row = $sth->fetchrow_array;
+ croak "Unable to find $params{type} entries for $condition - $errmsg" if $err;
- # Done with $sth
- $sth->finish;
+ my $todaysDate = Today2SQLDatetime;
- # Retrieve returned value
- $count = $row[0] ? $row[0] : 0;
+ while (my $rec = $db->getnext) {
+ my $days = _retention2Days($rec->{retention});
- # Just return if there's nothing to delete
- return $count if ($count == 0);
+ my $agedDate = SubtractDays($todaysDate, $days);
- # Get data for these entries
- $statement = "select type, sequence, hit_count from list where userid = '$userid' and type = '$listtype' and last_hit < '$timestamp'";
+ # If last_hit < retentiondays then delete
+ if (Compare($rec->{last_hit}, $agedDate) == -1) {
+ unless ($params{dryrun}) {
+ DeleteList(
+ userid => $params{userid},
+ type => $params{type},
+ sequence => $rec->{sequence},
+ );
- # Prepare statement
- $sth = $DB->prepare($statement)
- or DBError('CleanList: Unable to prepare statement', $statement);
+ if ($params{log}) {
+ $rec->{pattern} //= '';
+ $rec->{domain} //= '';
- # Execute statement
- $sth->execute
- or DBError('CleanList: Unable to execute statement', $statement);
-
- $count = 0;
-
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
-
- my $hit_count = pop(@row);
- my $sequence = pop(@row);
- my $listtype = pop(@row);
-
- if ($hit_count == 0) {
- $count++;
+ $params{log}->msg("Deleted $rec->{userid}:$params{type}:$rec->{sequence} "
+ . "$rec->{pattern}\@$rec->{domain} $dryrunstr");
+ $params{log}->dbug("last hit = $rec->{last_hit} < agedDate = $agedDate");
+ } # if
- $statement = "delete from list where userid='$userid' and type='$listtype' and sequence=$sequence";
- $DB->do($statement)
- or DBError('CleanList: Unable to execute statement', $statement);
+ $count++;
+ } # unless
} else {
- # Age entry: Sometimes entries are initially very popular and
- # the $hit_count gets very high quickly. Then the domain is
- # abandoned and no activity happens. One case recently observed
- # was for phentermine.com. The $hit_count initially soared to
- # 1920 within a few weeks. Then it all stopped as of
- # 07/13/2007. Obvisously this domain was shutdown. With the
- # previous aging algorithm of simply subtracting 1 this
- # phentermine.com entry would hang around for over 5 years!
- #
- # So the tack here is to age the entry by 10% until the $hit_count
- # is less than 30 then we revert to the old method of subtracting 1.
- if ($hit_count < 30) {
- $hit_count--;
- } else {
- $hit_count = int($hit_count / 1.1);
- } # if
-
- $statement = "update list set hit_count=$hit_count where userid='$userid' and type='$listtype' and sequence=$sequence;";
- $DB->do($statement)
- or DBError('CleanList: Unable to execute statement', $statement);
+ $params{log}->dbug("$rec->{userid}:$params{type}:$rec->{sequence}: nodelete $dryrunstr "
+ . "last hit = $rec->{last_hit} >= agedDate = $agedDate")
+ if $params{log};
} # if
} # while
- ResequenceList($userid, $listtype);
+ ResequenceList(
+ userid => $params{userid},
+ type => $params{type},
+ ) if $count and !$params{dryrun};
- return $count;
+ return wantarray ? ($count, $msg) : $count;
} # CleanList
-sub CloseDB() {
- $DB->disconnect;
+sub CountEmail(%) {
+ my (%params) = @_;
- return;
-} # CloseDB
+ CheckParms(['userid'], \%params);
-sub CountMsg($) {
- my ($sender) = @_;
+ my $table = 'email';
+ my $condition = "userid='$params{userid}'";
+ $condition .= " and $params{additional}" if $params{additional};
- return count('email', "userid = '$userid' and sender like '%$sender%'");
-} # CountMsg
+ return $db->count($table, $condition);
+} # CountEmail
-sub DBError($$) {
- my ($msg, $statement) = @_;
+sub CountList(%) {
+ my (%params) = @_;
- print 'MAPS::' . $msg . "\nError #" . $DB->err . ' ' . $DB->errstr . "\n";
+ CheckParms(['userid', 'type'], \%params);
- if ($statement) {
- print "SQL Statement: $statement\n";
- } # if
+ my $table = 'list';
+ my $condition = "userid='$params{userid}' and type='$params{type}'";
- exit $DB->err;
-} # DBError
+ return $db->count($table, $condition);
+} # CountList
-sub Decrypt ($$) {
- my ($password, $userid) = @_;
+sub CountLog(%) {
+ my (%params) = @_;
- my $statement = "select decode('$password','$userid')";
+ CheckParms(['userid'], \%params);
- my $sth = $DB->prepare($statement)
- or DBError('Decrypt: Unable to prepare statement', $statement);
+ my ($additional_condition) = delete $params{additional} || '';
- $sth->execute
- or DBError('Decrypt: Unable to execute statement', $statement);
+ my $condition = "userid='$userid'";
+ $condition .= " and $additional_condition" if $additional_condition;
- # Get return value, which should be the encoded password
- my @row = $sth->fetchrow_array;
+ return $db->count_distinct('log', 'sender', $condition);
+} # CountLog
- # Done with $sth
- $sth->finish;
+sub Decrypt ($$) {
+ my ($password, $userid) = @_;
- return $row[0]
+ return $db->decode($password, $userid);
} # Decrypt
-sub DeleteEmail($) {
- my $sender = shift;
-
- my ($username, $domain) = split /@/, $sender;
- my $condition;
-
- if ($username eq '') {
- $condition = "userid = '$userid' and sender like '%\@$domain'";
- } else {
- $condition = "userid = '$userid' and sender = '$sender'";
- } # if
-
- # First see if anything needs to be deleted
- my $count = count('email', $condition);
-
- # Just return if there's nothing to delete
- return $count if ($count == 0);
-
- my $statement = 'delete from email where ' . $condition;
+sub DeleteEmail(%) {
+ my (%rec) = @_;
- $DB->do($statement)
- or DBError('DeleteEmail: Unable to execute statement', $statement);
-
- return $count;
-} # DeleteEmail
-
-sub DeleteList($$) {
- my ($type, $sequence) = @_;
-
- # First see if anything needs to be deleted
- my $count = count('list', "userid = '$userid' and type = '$type' and sequence = '$sequence'");
+ my $table = 'email';
- # Just return if there's nothing to delete
- return $count if ($count == 0);
+ CheckParms(['userid', 'sender'], \%rec);
- my $statement = "delete from list where userid = '$userid' and type = '$type' and sequence = '$sequence'";
-
- $DB->do($statement)
- or DBError('DeleteList: Unable to execute statement', $statement);
-
- return $count;
-} # DeleteList
-
-sub DeleteLog($) {
- my ($sender) = @_;
-
- my ($username, $domain) = split /@/, $sender;
+ my ($username, $domain) = split /@/, $rec{sender};
my $condition;
- if ($username eq '') {
- $condition = "userid = '$userid' and sender like '%\@$domain'";
+ if ($username) {
+ $condition = "userid = '$rec{userid}' and sender = '$rec{sender}'";
} else {
- $condition = "userid = '$userid' and sender = '$sender'";
+ $condition = "userid = '$rec{userid}' and sender like '%\@$domain'";
} # if
- # First see if anything needs to be deleted
- my $count = count('log', $condition);
+ return $db->delete($table, $condition);
+} # DeleteEmail
- # Just return if there's nothing to delete
- return $count if ($count == 0);
+sub DeleteList(%) {
+ my (%rec) = @_;
- my $statement = 'delete from log where ' . $condition;
+ CheckParms(['userid', 'type', 'sequence'], \%rec);
- $DB->do($statement)
- or DBError('DeleteLog: Unable to execute statement', $statement);
+ my $condition = "userid = '$rec{userid}' and "
+ . "type = '$rec{type}' and "
+ . "sequence = $rec{sequence}";
- return $count;
-} # DeleteLog
+ return $db->delete('list', $condition);
+} # DeleteList
sub Encrypt($$) {
my ($password, $userid) = @_;
- my $statement = "select encode('$password','$userid')";
-
- my $sth = $DB->prepare($statement)
- or DBError('Encrypt: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('Encrypt: Unable to execute statement', $statement);
-
- # Get return value, which should be the encoded password
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- return $row[0];
+ return $db->encode($password, $userid);
} # Encrypt
-sub FindEmail(;$$) {
- my ($sender, $date) = @_;
-
- my $statement;
-
- $sender //= '';
- $date //= '';
-
- $statement = "select * from email where userid = '$userid'";
+sub FindEmail(%) {
+ my (%params) = @_;
- # Add conditions if present
- $statement .= " and sender = '$sender'" if $sender;
- $statement .= " and timestamp = '$date'" if $date;
+ CheckParms(['userid'], \%params);
- my $sth = $DB->prepare($statement)
- or DBError('FindEmail: Unable to prepare statement', $statement);
+ my $table = 'email';
+ my $condition = "userid='$params{userid}'";
+ $condition .= " and sender='$params{sender}'" if $params{sender};
+ $condition .= " and timestamp='$params{timestamp}'" if $params{timestamp};
- $sth->execute
- or DBError('FindEmail: Unable to execute statement', $statement);
-
- return $sth;
+ return $db->find($table, $condition);
} # FindEmail
-sub FindList($;$) {
+sub FindList(%) {
+ my (%params) = @_;
+
my ($type, $sender) = @_;
- my $statement;
+ CheckParms(['userid', 'type'], \%params);
- unless ($sender) {
- $statement = "select * from list where userid = '$userid' and type = '$type'";
- } else {
- my ($pattern, $domain) = split /\@/, $sender;
- $statement = "select * from list where userid = '$userid' and type = '$type' " .
- "and pattern = '$pattern' and domain = '$domain'";
- } # unless
+ my $table = 'list';
+ my $condition = "userid='$params{userid}' and type='$params{type}'";
- # Prepare statement
- my $sth = $DB->prepare($statement)
- or DBError('FindList: Unable to prepare statement', $statement);
+ if ($params{sender}) {
+ my ($username, $domain) = split /\@/, $params{sender};
- # Execute statement
- $sth->execute
- or DBError('FindList: Unable to execute statement', $statement);
+ # Split will return '' if either username or domain is missing. This messes
+ # up SQL's find as '' ~= NULL. Therefore we only specify username or domain
+ # if it is present.
+ $condition .= " and pattern='$username'" if $username;
+ $condition .= " and domain='$domain'" if $domain;
+ } # if
- # Get return value, which should be how many entries were deleted
- return $sth;
+ return $db->find($table, $condition);
} # FindList
sub FindLog($) {
my ($how_many) = @_;
my $start_at = 0;
- my $end_at = countlog();
+ my $end_at = CountLog(
+ userid => $userid,
+ );
if ($how_many < 0) {
$start_at = $end_at - abs ($how_many);
$start_at = 0 if ($start_at < 0);
} # if
- my $statement = "select * from log where userid = '$userid' order by timestamp limit $start_at, $end_at";
-
- # Prepare statement
- my $sth = $DB->prepare($statement)
- or DBError('FindLog: Unable to prepare statement', $statement);
+ my $table = 'log';
+ my $condition = "userid='$userid'";
+ my $additional = "order by timestamp limit $start_at, $end_at";
- # Execute statement
- $sth->execute
- or DBError('FindLog: Unable to execute statement', $statement);
-
- # Get return value, which should be how many entries were deleted
- return $sth;
+ return $db->find($table, $condition, '*', $additional);
} # FindLog
-sub FindUser(;$) {
- my ($userid) = @_;
+sub FindUser(%) {
+ my (%params) = @_;
- my $statement;
+ my $table = 'user';
+ my $condition = '';
- if (!defined $userid || $userid eq '') {
- $statement = 'select * from user';
- } else {
- $statement = "select * from user where userid = '$userid'";
- } # if
+ $condition = "userid='$userid'" if $params{userid};
- my $sth = $DB->prepare($statement)
- or DBError('FindUser: Unable to prepare statement', $statement);
+ return $db->find($table, $condition, $params{fields});
+} # FindUser
- $sth->execute
- or DBError('FindUser: Unable to execute statement', $statement);
+sub FindUsers() {
+ return $db->find('user', '', ['userid']);
+} # FindUsers
- return $sth;
-} # FindUser
+sub GetEmail() {
+ goto &_getnext;
+} # GetEmail
sub GetContext() {
return $userid;
} # GetContext
-sub GetEmail($) {
- my ($sth) = @_;
-
- my @email;
-
- if (@email = $sth->fetchrow_array) {
- my $message = pop @email;
- my $timestamp = pop @email;
- my $subject = pop @email;
- my $sender = pop @email;
- my $userid = pop @email;
- return $userid, $sender, $subject, $timestamp, $message;
- } else {
- return;
- } # if
-} # GetEmail
-
-sub GetList($) {
- my ($sth) = @_;
-
- my @list;
-
- if (@list = $sth->fetchrow_array) {
- my $last_hit = pop @list;
- my $hit_count = pop @list;
- my $sequence = pop @list;
- my $comment = pop @list;
- my $domain = pop @list;
- my $pattern = pop @list;
- my $type = pop @list;
- my $userid = pop @list;
- return $userid, $type, $pattern, $domain, $comment, $sequence, $hit_count, $last_hit;
- } else {
- return;
- } # if
+sub GetList() {
+ goto &_getnext;
} # GetList
-sub GetLog($) {
- my ($sth) = @_;
+sub GetLog() {
+ goto &_getnext;
+} # GetLog
- my @log;
+sub GetNextSequenceNo(%) {
+ my (%rec) = @_;
- if (@log = $sth->fetchrow_array) {
- my $message = pop @log;
- my $type = pop @log;
- my $sender = pop @log;
- my $timestamp = pop @log;
- my $userid = pop @log;
- return $userid, $timestamp, $sender, $type, $message;
- } else {
- return;
- } # if
-} # GetLog
+ CheckParms(['userid', 'type'], \%rec);
-sub GetNextSequenceNo($$) {
- my ($userid, $listtype) = @_;
+ my $table = 'list';
+ my $condition = "userid='$rec{userid}' and type='$rec{type}'";
- my $count = count ('list', "userid = '$userid' and type = '$listtype'");
+ my $count = $db->count('list', $condition);
return $count + 1;
} # GetNextSequenceNo
-sub GetUser($) {
- my ($sth) = @_;
-
- my @user;
-
- if (@user = $sth->fetchrow_array) {
- my $password = pop @user;
- my $email = pop @user;
- my $name = pop @user;
- my $userid = pop @user;
- return ($userid, $name, $email, $password);
- } else {
- return;
- } # if
+sub GetUser() {
+ goto &_getnext;
} # GetUser
sub GetUserInfo($) {
my ($userid) = @_;
- my $statement = "select name, email from user where userid='$userid'";
-
- my $sth = $DB->prepare($statement)
- or DBError('GetUserInfo: Unable to prepare statement', $statement);
+ my $userinfo = $db->getone('user', "userid='$userid'", ['name', 'email']);
- $sth->execute
- or DBError('GetUserInfo: Unable to execute statement', $statement);
+ return %{$db->getone('user', "userid='$userid'", ['name', 'email'])};
- my @userinfo = $sth->fetchrow_array;
- my $user_email = lc (pop @userinfo);
- my $username = lc (pop @userinfo);
-
- $sth->finish;
-
- return ($username, $user_email);
+ return %$userinfo;
} # GetUserInfo
sub GetUserOptions($) {
my ($userid) = @_;
- my $statement = "select * from useropts where userid = '$userid'";
-
- my $sth = $DB->prepare($statement)
- or DBError('GetUserOptions: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('GetUserOptions: Unable to execute statement', $statement);
+ my $table = 'useropts';
+ my $condition = "userid='$userid'";
- my @useropts;
+ $db->find($table, $condition);
- # Empty hash
- %useropts = ();
+ my %useropts;
- while (@useropts = $sth->fetchrow_array) {
- my $value = pop @useropts;
- my $name = pop @useropts;
-
- pop @useropts;
-
- $useropts{$name} = $value;
+ while (my $rec = $db->getnext) {
+ $useropts{$rec->{name}} = $rec->{value};
} # while
- $sth->finish;
-
return %useropts;
} # GetUserOptions
-sub GetRows ($) {
- my ($statement) = @_;
-
- my $sth = $DB->prepare($statement)
- or DBError('Unable to prepare statement' , $statement);
-
- $sth->execute
- or DBError('Unable to execute statement' , $statement);
-
- my @array;
-
- while (my @row = $sth->fetchrow_array) {
- for (@row) {
- push @array, $_;
- } # for
- } # while
-
- return @array;
-} # GetRows
-
sub Login($$) {
my ($userid, $password) = @_;
my $dbpassword = UserExists($userid);
# Return -1 if user doesn't exist
- return -1 if !$dbpassword;
+ return -1 unless $dbpassword;
# Return -2 if password does not match
if ($password eq $dbpassword) {
# Nulllist will simply discard the message.
my ($sender, $sequence, $hit_count) = @_;
- RecordHit("null", $sequence, ++$hit_count) if $sequence;
+ RecordHit(
+ userid => $userid,
+ type => 'null',
+ sequence => $sequence,
+ hit_count => ++$hit_count,
+ ) if $sequence;
# Discard Message
- Logmsg("nulllist", $sender, "Discarded message");
+ Logmsg(
+ userid => $userid,
+ type => 'nulllist',
+ sender => $sender,
+ message => 'Discarded message'
+ );
return;
} # Nulllist
sub OnNulllist($;$) {
my ($sender, $update) = @_;
- return CheckOnList("null", $sender, $update);
+ return CheckOnList('null', $sender, $update);
} # CheckOnNulllist
sub OnWhitelist($;$$) {
SetContext($userid) if $userid;
- return CheckOnList("white", $sender, $update);
+ return CheckOnList('white', $sender, $update);
} # OnWhitelist
-sub OpenDB($$) {
- my ($username, $password) = @_;
-
- my $dbname = 'MAPS';
- my $dbdriver = 'mysql';
- my $dbserver = $ENV{MAPS_SERVER} || 'localhost';
-
- if (!$DB || $DB eq '') {
- #$dbserver='localhost';
- $DB = DBI->connect("DBI:$dbdriver:$dbname:$dbserver", $username, $password, {PrintError => 0})
- or croak "Couldn't connect to $dbname database as $username\n" . $DBI::errstr;
- } # if
-
- return $DB;
-} # OpenDB
-
-BEGIN {
- my $MAPS_username = "maps";
- my $MAPS_password = "spam";
-
- OpenDB($MAPS_username, $MAPS_password);
-} # BEGIN
-
-END {
- CloseDB;
-} # END
-
-
sub OptimizeDB() {
- my $statement = 'lock tables email read, list read, log read, user read, useropts read';
- my $sth = $DB->prepare($statement)
- or DBError('OptimizeDB: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('OptimizeDB: Unable to execute statement', $statement);
+ my @tables = qw(email list log user useropts);
- $statement = 'check table email, list, log, user, useropts';
- $sth = $DB->prepare($statement)
- or DBError('OptimizeDB: Unable to prepare statement', $statement);
+ my ($err, $msg) = $db->lock('read', \@tables);
- $sth->execute
- or DBError('OptimizeDB: Unable to execute statement', $statement);
+ croak "Unable to lock table - $msg" if $err;
- $statement = 'unlock tables';
- $sth = $DB->prepare($statement)
- or DBError('OptimizeDB: Unable to prepare statement', $statement);
+ ($err, $msg) = $db->check(\@tables);
- $sth->execute
- or DBError('OptimizeDB: Unable to execute statement', $statement);
+ croak 'Unable to check tables ' . $msg if $err;
- $statement = 'optimize table email, list, log, user, useropts';
- $sth = $DB->prepare($statement)
- or DBError('OptimizeDB: Unable to prepare statement', $statement);
+ ($err, $msg) = $db->optimize(\@tables);
- $sth->execute
- or DBError('OptimizeDB: Unable to execute statement', $statement);
+ croak 'Unable to optimize tables ' . $msg if $err;
- return;
+ return $db->unlock();
} # OptimizeDB
sub ReadMsg($) {
return $sender, $sender_long, $reply_to, $subject, join "\n", @data;
} # ReadMsg
-sub RecordHit($$$) {
- my ($listtype, $sequence, $hit_count) = @_;
+sub RecordHit(%) {
+ my (%rec) = @_;
- my $current_date = UnixDatetime2SQLDatetime(scalar(localtime));
+ CheckParms(['userid', 'type', 'sequence', ], \%rec);
- my $statement = "update list set hit_count=$hit_count, last_hit='$current_date' where userid='$userid' and type='$listtype' and sequence=$sequence";
+ my $current_date = UnixDatetime2SQLDatetime(scalar(localtime));
- $DB->do($statement)
- or DBError('RecordHit: Unable to do statement', $statement);
+ my $table = 'list';
+ my $condition = "userid='rec{userid} and type=$rec{type} and sequence='$rec{sequence}";
- return;
+ return $db->modify(
+ table => $table,
+ condition => $condition,
+ %rec,
+ );
} # RecordHit
-sub ResequenceList($$) {
- my ($userid, $type) = @_;
-
- return 1 if $type ne 'white' && $type ne 'black' && $type ne 'null';
-
- return 2 unless UserExists($userid);
+sub ResequenceList(%) {
+ my (%params) = @_;
- my $statement = 'lock tables list write';
- my $sth = $DB->prepare($statement)
- or DBError('ResquenceList: Unable to prepare statement', $statement);
+ CheckParms(['userid', 'type'], \%params);
- $sth->execute
- or DBError('ResequenceList: Unable to execute statement', $statement);
+ # Data checks
+ return 1 unless $params{type} =~ /(white|black|null)/;
+ return 2 unless UserExists($params{userid});
- # Now get all of the list entries renumbering as we go
- $statement = <<"END";
-select
- pattern,
- domain,
- comment,
- sequence,
- hit_count,
- last_hit
-from
- list
-where
- userid = '$userid' and
- type = '$type'
-order by
- hit_count desc
-END
+ my $table = 'list';
+ my $condition = "userid='$params{userid}' and type ='$params{type}'";
- $sth = $DB->prepare($statement)
- or DBError('ResequenceList: Unable to prepare statement', $statement);
+ # Lock the table
+ $db->lock('write', $table);
- $sth->execute
- or DBError('ResequenceList: Unable to execute statement', $statement);
-
- my $sequence = 1;
- my @new_rows;
-
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
-
- my %record = (
- last_hit => pop @row,
- hit_count => pop @row,
- new_sequence => $sequence++,
- old_sequence => pop @row,
- comment => $DB->quote(pop @row) || '',
- domain => $DB->quote(pop @row) || '',
- pattern => $DB->quote(pop @row) || '',
- );
-
- push @new_rows, \%record;
- } # while
+ # Get all records for $userid and $type
+ my $listrecs = $db->get($table, $condition);
# Delete all of the list entries for this $userid and $type
- $statement = "delete from list where userid='$userid' and type='$type'";
-
- $DB->do($statement)
- or DBError('ResequenceList: Unable to do statement', $statement);
-
- # Re-add list with new sequence numbers
- for (@new_rows) {
- my %record = %$_;
- my $statement = <<"END";
-insert into
- list
-values (
- '$userid',
- '$type',
- $record{pattern},
- $record{domain},
- $record{comment},
- '$record{new_sequence}',
- '$record{hit_count}',
- '$record{last_hit}'
-)
-END
-
- $DB->do($statement)
- or DBError('ResequenceList: Unable to do statement', $statement);
- } # for
-
- $statement = 'unlock tables';
- $sth = $DB->prepare($statement)
- or DBError('OptimizeDB: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('OptimizeDB: Unable to execute statement', $statement);
-
- return 0;
-} # ResequenceList
-
-sub ResequenceListold($$) {
- my ($userid, $type) = @_;
-
- return 1 if $type ne 'white' && $type ne 'black' && $type ne 'null';
-
- return 2 unless UserExists($userid);
-
- my $statement = "select sequence from list where userid = '$userid' "
- . " and type = '$type' order by sequence";
-
- my $sth = $DB->prepare($statement)
- or DBError('ResequenceList: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('ResequenceList: Unable to execute statement', $statement);
+ my ($count, $msg) = $db->delete($table, $condition);
+ # Now re-add list entries renumbering them
my $sequence = 1;
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
-
- my $old_sequence = pop @row;
+ for (@$listrecs) {
+ $_->{sequence} = $sequence++;
- if ($old_sequence != $sequence) {
- my $update_statement = "update list set sequence = $sequence " .
- "where userid = '$userid' and " .
- "type = '$type' and sequence = $old_sequence";
+ my ($err, $msg) = $db->add($table, %$_);
- $DB->do($update_statement)
- or DBError('ResequenceList: Unable to do statement', $statement);
- } # if
+ croak $msg if $err;
+ } # for
- $sequence++;
- } # while
+ $db->unlock;
return 0;
} # ResequenceList
-sub ReturnEmails($$$;$$) {
- my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
-
- $start_at ||= 0;
-
- my $statement;
-
- if ($date) {
- my $sod = $date . ' 00:00:00';
- my $eod = $date . ' 23:59:59';
-
- if ($type eq 'returned') {
- $statement = <<"END";
-select
- log.sender
-from
- log,
- email
-where
- log.sender = email.sender and
- log.userid = '$userid' and
- log.timestamp > '$sod' and
- log.timestamp < '$eod' and
- log.type = '$type'
-group by
- log.sender
-limit
- $start_at, $nbr_emails
-END
- } else {
- $statement = <<"END";
-select
- sender
-from
- log
-where
- userid = '$userid' and
- timestamp > '$sod' and
- timestamp < '$eod' and
- type = '$type'
-group by
- sender
-limit
- $start_at, $nbr_emails
-END
- } # if
- } else {
- if ($type eq 'returned') {
- $statement = <<"END";
-select
- log.sender
-from
- log,
- email
-where
- log.sender = email.sender and
- log.userid = '$userid' and
- log.type = '$type'
-group by
- log.sender
-order by
- log.timestamp desc
-limit
- $start_at, $nbr_emails
-END
- } else {
- $statement = <<"END";
-select
- sender
-from
- log
-where
- userid = '$userid' and
- type = '$type'
-group by
- sender
-order by
- timestamp desc
-limit
- $start_at, $nbr_emails
-END
- } # if
- } # if
-
- my $sth = $DB->prepare($statement)
- or DBError('ReturnEmails: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('ReturnEmails: Unable to execute statement', $statement);
-
- my @emails;
-
- while (my $sender = $sth->fetchrow_array) {
- my $earliestDate;
-
- # Get emails for this sender. Format an array of subjects and timestamps.
- my @messages;
-
- $statement = "select timestamp, subject from email where userid = '$userid' " .
- "and sender = '$sender'";
-
- my $sth2 = $DB->prepare($statement)
- or DBError('ReturnEmails: Unable to prepare statement', $statement);
-
- $sth2->execute
- or DBError('ReturnEmails: Unable to execute statement', $statement);
-
- while (my @row = $sth2->fetchrow_array) {
- my $subject = pop @row;
- my $date = pop @row;
-
- if ($earliestDate) {
- my $earliestDateShort = substr $earliestDate, 0, 10;
- my $dateShort = substr $date, 0, 10;
-
- if ($earliestDateShort eq $dateShort and
- $earliestDate > $date) {
- $earliestDate = $date if $earliestDateShort eq $dateShort;
- } # if
- } else {
- $earliestDate = $date;
- } # if
-
- push @messages, [$subject, $date];
- } # while
-
- # Done with sth2
- $sth2->finish;
-
- $earliestDate ||= '';
-
- unless ($type eq 'returned') {
- push @emails, [$earliestDate, [$sender, @messages]];
- } else {
- push @emails, [$earliestDate, [$sender, @messages]]
- if @messages > 0;
- } # unless
- } # while
-
- # Done with $sth
- $sth->finish;
-
- return @emails;
-} # ReturnEmails
-
-sub ReturnList($$$) {
- my ($type, $start_at, $lines) = @_;
-
- $lines ||= 10;
+sub ReturnList(%) {
+ my (%params) = @_;
- my $statement;
+ CheckParms(['userid', 'type'], \%params);
- if ($start_at) {
- $statement = "select * from list where userid = '$userid' " .
- "and type = '$type' order by sequence " .
- "limit $start_at, $lines";
- } else {
- $statement = "select * from list where userid = '$userid' " .
- "and type = '$type' order by sequence";
- } # if
-
- my $sth = $DB->prepare($statement)
- or DBError('ReturnList: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('ReturnList: Unable to execute statement', $statement);
+ my $start_at = delete $params{start_at} || 0;
+ my $lines = delete $params{lines} || 10;
- my @list;
- my $i = 0;
+ my $table = 'list';
+ my $condition = "userid='$params{userid}' and type='$params{type}'";
+ my $additional = "order by sequence limit $start_at, $lines";
- while (my @row = $sth->fetchrow_array) {
- last if $i++ > $lines;
-
- my %list;
-
- $list{last_hit} = pop @row;
- $list{hit_count} = pop @row;
- $list{sequence} = pop @row;
- $list{comment} = pop @row;
- $list{domain} = pop @row;
- $list{pattern} = pop @row;
- $list{type} = pop @row;
- $list{userid} = pop @row;
- push @list, \%list;
- } # for
-
- return @list;
+ return $db->get($table, $condition, '*', $additional);
} # ReturnList
-sub ReturnListEntry($$) {
- my ($type, $sequence) = @_;
-
- my $statement = "select * from list where userid = '$userid' " .
- "and type = '$type' and sequence = '$sequence'";
-
- my $sth = $DB->prepare($statement)
- or DBError('ReturnListEntry: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('ReturnListEntry: Unable to execute statement', $statement);
-
- my %list;
- my @row = $sth->fetchrow_array;
-
- $list{sequence} = pop @row;
- $list{comment} = pop @row;
- $list{domain} = pop @row;
- $list{pattern} = pop @row;
- $list{type} = pop @row;
- $list{userid} = pop @row;
+sub ReturnMsg(%) {
+ my (%params) = @_;
- return %list;
-} # ReturnListEntry
-
-# Added reply_to. Previously we passed reply_to into here as sender. This
-# caused a problem in that we were filtering as per sender but logging it
-# as reply_to. We only need reply_to for SendMsg so as to honor reply_to
-# so we now pass in both sender and reply_to
-sub ReturnMsg($$$$) {
# ReturnMsg will send back to the $sender the register message.
# Messages are saved to be delivered when the $sender registers.
- my ($sender, $reply_to, $subject, $data) = @_;
+ #
+ # Added reply_to. Previously we passed reply_to into here as sender. This
+ # caused a problem in that we were filtering as per sender but logging it
+ # as reply_to. We only need reply_to for SendMsg so as to honor reply_to
+ # so we now pass in both sender and reply_to
+
+ CheckParms(['userid', 'sender', 'reply_to', 'subject', 'data'], \%params);
+
+ #my ($sender, $reply_to, $subject, $data) = @_;
# Check to see if this sender has already emailed us.
- my $msg_count = CountMsg($sender);
+ my $msg_count = $db->count('email', "userid='$userid' and sender like '%$params{sender}%'");
if ($msg_count < 5) {
# Return register message
- my @msg;
-
- for (split /\n/,$data) {
- push @msg, "$_\n";
- } # for
+ SendMsg(
+ userid => $params{userid},
+ sender => $params{reply_to},
+ subject => 'Your email has been returned by MAPS',
+ msgfile => "$mapsbase/register.html",
+ data => $params{data},
+ ) if $msg_count == 0;
+
+ Logmsg(
+ userid => $params{userid},
+ type => 'returned',
+ sender => $params{sender},
+ message => 'Sent register reply',
+ );
- SendMsg($reply_to,
- "Your email has been returned by MAPS",
- "$mapsbase/register.html",
- GetContext,
- @msg)
- if $msg_count == 0;
- Logmsg("returned", $sender, "Sent register reply");
# Save message
- SaveMsg($sender, $subject, $data);
+ SaveMsg($params{sender}, $params{subject}, $params{data});
} else {
- Add2Nulllist($sender, GetContext, "Auto Null List - Mail loop");
- Logmsg("mailloop", $sender, "Mail loop encountered");
+ Add2Nulllist($params{sender}, GetContext, "Auto Null List - Mail loop");
+
+ Logmsg(
+ userid => $params{userid},
+ type => 'mailloop',
+ sender => $params{sender},
+ message => 'Mail loop encountered',
+ );
} # if
return;
} # ReturnMsg
-sub ReturnMessages($$) {
- my ($userid, $sender) = @_;
-
- my $statement = <<"END";
-select
- subject,
- timestamp
-from
- email
-where
- userid = '$userid' and
- sender = '$sender'
-group by
- timestamp desc
-END
+sub ReturnMessages(%) {
+ my (%params) = @_;
- my $sth = $DB->prepare($statement)
- or DBError('ReturnMessages: Unable to prepare statement', $statement);
+ CheckParms(['userid', 'sender'], \%params);
- $sth->execute
- or DBError('ReturnMessages: Unable to execute statement', $statement);
+ my $table = 'email';
+ my $condition = "userid='$params{userid}' and sender='$params{sender}'";
+ my $fields = ['subject', 'timestamp'];
+ my $additional = 'group by timestamp desc';
- my @messages;
-
- while (my @row = $sth->fetchrow_array) {
- my $date = pop @row;
- my $subject = pop @row;
-
- push @messages, [$subject, $date];
- } # while
-
- $sth->finish;
-
- return @messages;
+ return $db->get($table, $condition, $fields, $additional);
} # ReturnMessages
-# This subroutine returns an array of senders in reverse chronological
-# order based on time timestamp from the log table of when we returned
-# their message. The complication here is that a single sender may
-# send multiple times in a single day. So if spammer@foo.com sends
-# spam @ 1 second after midnight and then again at 2 Pm there will be
-# at least two records in the log table saying that we returned his
-# email. Getting records sorted by timestamp desc will have
-# spammer@foo.com listed twice. But we want him listed only once, as
-# the first entry in the returned array. Plus we may be called
-# repeatedly with different $start_at's. Therefore we need to process
-# the whole list of returns for today, eliminate duplicate entries for
-# a single sender then slice the resulting array.
-sub ReturnSenders($$$;$$) {
- my ($userid, $type, $start_at, $nbr_emails, $date) = @_;
-
- $start_at ||= 0;
-
- my $dateCond = '';
-
- if ($date) {
- my $sod = $date . ' 00:00:00';
- my $eod = $date . ' 23:59:59';
-
- $dateCond = "and timestamp > '$sod' and timestamp < '$eod'";
+sub ReturnSenders(%) {
+ my (%params) = @_;
+ # This subroutine returns an array of senders in reverse chronological
+ # order based on time timestamp from the log table of when we returned
+ # their message. The complication here is that a single sender may
+ # send multiple times in a single day. So if spammer@foo.com sends
+ # spam @ 1 second after midnight and then again at 2 Pm there will be
+ # at least two records in the log table saying that we returned his
+ # email. Getting records sorted by timestamp desc will have
+ # spammer@foo.com listed twice. But we want him listed only once, as
+ # the first entry in the returned array. Plus we may be called
+ # repeatedly with different $start_at's. Therefore we need to process
+ # the whole list of returns for today, eliminate duplicate entries for
+ # a single sender then slice the resulting array.
+ CheckParms(['userid', 'type', 'lines'], \%params);
+
+ my $table = 'log';
+ my $condition = "userid='$params{userid}' and type='$params{type}'";
+ my $additional = 'order by timestamp desc';
+
+ $params{start_at} ||= 0;
+
+ if ($params{date}) {
+ $condition .= "and timestamp > '$params{date} 00:00:00' and "
+ . "timestamp < '$params{date} 23:59:59'";
} # if
- my $statement = <<"END";
-select
- sender,
- timestamp
-from
- log
-where
- userid = '$userid' and
- type = '$type'
- $dateCond
-order by
- timestamp desc
-END
-
- my $sth = $DB->prepare($statement)
- or DBError('ReturnSenders: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('ReturnSenders: Unable to execute statement', $statement);
+ $db->find($table, $condition, '*', $additional);
# Watch the distinction between senders (plural) and sender (singular)
- my (%senders, %sendersByTimestamp);
+ my %senders;
# Run through the results and add to %senders by sender key. This
# results in a hash that has the sender in it and the first
# above select statement, and we've narrowed it down to only log
# message that occurred for the given $date, we will have a hash
# containing 1 sender and the latest timestamp for the day.
- while (my $senderRef = $sth->fetchrow_hashref) {
- my %sender = %{$senderRef};
-
- $senders{$sender{sender}} = $sender{timestamp}
- unless $senders{$sender{sender}};
+ while (my $rec = $db->getnext) {
+ $senders{$rec->{sender}} = $rec->{timestamp}
+ unless $senders{$rec->{sender}};
} # while
- $sth->finish;
-
# Make a hash whose keys are the timestamp (so we can later sort on
# them).
- while (my ($key, $value) = each %senders) {
- $sendersByTimestamp{$value} = $key;
- } # while
+ my %sendersByTimestamp = reverse %senders;
my @senders;
for (sort { $b cmp $a } keys %sendersByTimestamp);
# Finally slice for the given range
- my $end_at = $start_at + $nbr_emails - 1;
+ my $end_at = $params{start_at} + $params{lines} - 1;
$end_at = (@senders - 1)
if $end_at > @senders;
- return (@senders) [$start_at .. $end_at];
+ return (@senders) [$params{start_at} .. $end_at];
} # ReturnSenders
sub SaveMsg($$$) {
my ($sender, $subject, $data) = @_;
- AddEmail($sender, $subject, $data);
+ AddEmail(
+ userid => $userid,
+ sender => $sender,
+ subject => $subject,
+ data => $data,
+ );
return;
} # SaveMsg
-sub SearchEmails($$) {
- my ($userid, $searchfield) = @_;
+sub SearchEmails(%) {
+ my (%params) = @_;
- my @emails;
-
- my $statement =
- "select sender, subject, timestamp from email where userid = '$userid' and (
- sender like '%$searchfield%' or subject like '%$searchfield%')
- order by timestamp desc";
+ CheckParms(['userid', 'search'], \%params);
- my $sth = $DB->prepare($statement)
- or DBError('SearchEmails: Unable to prepare statement', $statement);
+ my $table = 'email';
+ my $fields = ['sender', 'subject', 'timestamp'];
+ my $condition = "userid='$params{userid}' and (sender like '\%$params{search}\%' "
+ . "or subject like '\%$params{search}\%')";
+ my $additional = 'order by timestamp desc';
- $sth->execute
- or DBError('SearchEmails: Unable to execute statement', $statement);
+ my ($err, $msg) = $db->find($table, $condition, $fields, $additional);
- while (my @row = $sth->fetchrow_array) {
- my $date = pop @row;
- my $subject = pop @row;
- my $sender = pop @row;
+ my @emails;
- push @emails, [$sender, $subject, $date];
+ while (my $rec = $db->getnext) {
+ push @emails, $rec;
} # while
- $sth->finish;
-
return @emails;
} # SearchEmails
-sub SendMsg($$$$@) {
+sub SendMsg(%) {
# SendMsg will send the message contained in $msgfile.
- my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
+ my (%params) = @_;
+
+ #my ($sender, $subject, $msgfile, $userid, @spammsg) = @_;
my @lines;
# Open return message template file
- open my $return_msg_file, '<', $msgfile
- or die "Unable to open return msg file ($msgfile): $!\n";
+ open my $return_msg_file, '<', $params{msgfile}
+ or die "Unable to open return msg file ($params{msgfile}): $!\n";
# Read return message template file and print it to $msg_body
while (<$return_msg_file>) {
} # if
if (/\$sender/) {
# Replace sender
- s/\$sender/$sender/;
+ s/\$sender/$params{sender}/;
} #if
push @lines, $_;
# Create the message, and set up the mail headers:
my $msg = MIME::Entity->build(
From => "MAPS\@DeFaria.com",
- To => $sender,
- Subject => $subject,
+ To => $params{sender},
+ Subject => $params{subject},
Type => "text/html",
Data => \@lines
);
# Need to obtain the spam message here...
+ my @spammsg = split "\n", $params{data};
+
$msg->attach(
Type => "message",
Disposition => "attachment",
sub SetContext($) {
my ($to_user) = @_;
- my $old_user = $userid;
-
if (UserExists($to_user)) {
$userid = $to_user;
- GetUserOptions($userid);
return GetUserInfo $userid;
} else {
return 0;
my ($userid) = @_;
my $total_space = 0;
- my %msg_space;
-
- my $statement = "select * from email where userid = '$userid'";
- my $sth = $DB->prepare($statement)
- or DBError('Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('Unable to execute statement', $statement);
-
- while (my @row = $sth->fetchrow_array) {
- last if !@row;
-
- my $data = pop @row;
- my $timestamp = pop @row;
- my $subject = pop @row;
- my $sender = pop @row;
- my $user = pop @row;
-
- my $msg_space =
- length ($userid) +
- length ($sender) +
- length ($subject) +
- length ($timestamp) +
- length ($data);
-
- $total_space += $msg_space;
- $msg_space{$sender} += $msg_space;
+ my $table = 'email';
+ my $condition = "userid='$userid'";
+
+ $db->find($table, $condition);
+
+ while (my $rec = $db->getnext) {
+ $total_space +=
+ length($rec->{userid}) +
+ length($rec->{sender}) +
+ length($rec->{subject}) +
+ length($rec->{timestamp}) +
+ length($rec->{data});
} # while
- $sth->finish;
-
- return wantarray ? %msg_space : $total_space;
+ return $total_space;
} # Space
-sub UpdateList($$$$$$$) {
- my ($userid, $type, $pattern, $domain, $comment, $hit_count, $sequence) = @_;
+sub UpdateList(%) {
+ my (%rec) = @_;
- if (!$pattern || $pattern eq '') {
- $pattern = 'NULL';
- } else {
- $pattern = "'" . quotemeta ($pattern) . "'";
- } # if
+ CheckParms(['userid', 'type', 'sequence'], \%rec);
- if (!$domain || $domain eq '') {
- $domain = 'NULL';
- } else {
- $domain = "'" . quotemeta ($domain) . "'";
- } # if
+ my $table = 'list';
+ my $condition = "userid = '$rec{userid}' and type = '$rec{type}' and sequence = $rec{sequence}";
- if (!$comment || $comment eq '') {
- $comment = 'NULL';
- } else {
- $comment = "'" . quotemeta ($comment) . "'";
+ if ($rec{pattern} =~ /\@/ and !$rec{domain}) {
+ ($rec{pattern}, $rec{domain}) = split /\@/, $rec{pattern};
+ } elsif (!$rec{pattern} and $rec{domain} =~ /\@/) {
+ ($rec{pattern}, $rec{domain}) = split /\@/, $rec{domain};
+ } elsif (!$rec{pattern} and !$rec{domain}) {
+ return "Must specify either Username or Domain";
} # if
- if (!$hit_count || $hit_count eq '') {
- $hit_count = 0;
- #} else {
- # TODO: Check if numeric
- } # fi
-
- my $statement =
- 'update list set ' .
- "pattern = $pattern, domain = $domain, comment = $comment, hit_count = $hit_count " .
- "where userid = '$userid' and type = '$type' and sequence = $sequence";
+ $rec{pattern} //= 'null';
+ $rec{domain} //= 'null';
+ $rec{comment} //= 'null';
- $DB->do($statement)
- or DBError('UpdateList: Unable to do statement', $statement);
+ if ($rec{retention}) {
+ $rec{retention} = lc $rec{retention};
+ } # if
- return 0;
+ return $db->update($table, $condition, %rec);
} # UpdateList
-sub UpdateUser($$$$) {
- my ($userid, $fullname, $email, $password) = @_;
-
- return 1 if !UserExists($userid);
+sub UpdateUser(%) {
+ my (%rec) = @_;
- my $statement;
+ CheckParms(['userid', 'name', 'email'], \%rec);
- if (!defined $password || $password eq '') {
- $statement = "update user set userid='$userid', name='$fullname', email='$email' where userid='$userid'";
- } else {
- $password = Encrypt $password, $userid;
- $statement = "update user set userid='$userid', name='$fullname', email='$email', password='$password' where userid='$userid'";
- } # if
+ return 1 unless UserExists($rec{userid});
- $DB->do($statement)
- or DBError('UpdateUser: Unable to do statement', $statement);
+ my $table = 'user';
+ my $condition = "userid='$rec{userid}'";
- return 0;
+ return $db->update($table, $condition, %rec);
} # UpdateUser
sub UpdateUserOptions ($@) {
return unless UserExists($userid);
- for (keys(%options)) {
- my $statement = "update useropts set value='$options{$_}' where userid='$userid' and name='$_'";
+ my $table = 'useropts';
+ my $condition = "userid='$userid' and name=";
- $DB->do($statement)
- or DBError('UpdateUserOption: Unable to do statement', $statement);
- } # for
+ $db->update($table, "$condition'$_'", (name=>$_, value=>$options{$_})) for (keys %options);
return;
} # UpdateUserOptions
return 0 unless $userid;
- my $statement = "select userid, password from user where userid = '$userid'";
-
- my $sth = $DB->prepare($statement)
- or DBError('UserExists: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('UserExists: Unable to execute statement', $statement);
-
- my @userdata = $sth->fetchrow_array;
+ my $table = 'user';
+ my $condition = "userid='$userid'";
- $sth->finish;
+ my $rec = $db->get($table, $condition);
- return 0 if scalar(@userdata) == 0;
+ return 0 if scalar(@$rec) == 0;
- my $dbpassword = pop @userdata;
- my $dbuserid = pop @userdata;
-
- if ($dbuserid ne $userid) {
- return 0;
- } else {
- return $dbpassword;
- } # if
+ return $rec->[0]{password};
} # UserExists
sub Whitelist ($$;$$) {
unlink "/tmp/MAPSMessage.$$";
if ($status == 0) {
- Logmsg("whitelist", $sender, "Delivered message");
+ Logmsg(
+ userid => $userid,
+ type => 'whitelist',
+ sender => $sender,
+ message => 'Delivered message',
+ );
} else {
Error("Unable to deliver message - is MAPSDeliver setgid? - $!");
} # if
- RecordHit("white", $sequence, ++$hit_count) if $sequence;
+ $hit_count++ if $sequence;
+
+ RecordHit(
+ userid => $userid,
+ type => 'white',
+ sequence => $sequence,
+ hit_count => $hit_count,
+ );
return $status;
} # Whitelist
-sub count($$) {
- my ($table, $condition) = @_;
-
- my $statement;
-
- if ($condition) {
- $statement = "select count(*) from $table where $condition";
- } else {
- $statement = "select count(*) from $table";
- } # if
-
- my $sth = $DB->prepare($statement)
- or DBError('count: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('count: Unable to execute statement', $statement);
-
- # Get return value, which should be how many message there are
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- my $count;
-
- # Retrieve returned value
- unless ($row[0]) {
- $count = 0
- } else {
- $count = $row[0];
- } # unless
-
- return $count
-} # count
-
-sub count_distinct($$$) {
- my ($table, $column, $condition) = @_;
-
- my $statement;
-
- if ($condition) {
- $statement = "select count(distinct $column) from $table where $condition";
- } else {
- $statement = "select count(distinct $column) from $table";
- } # if
-
- my $sth = $DB->prepare($statement)
- or DBError('count: Unable to prepare statement', $statement);
-
- $sth->execute
- or DBError('count: Unable to execute statement', $statement);
-
- # Get return value, which should be how many message there are
- my @row = $sth->fetchrow_array;
-
- # Done with $sth
- $sth->finish;
-
- # Retrieve returned value
- unless ($row[0]) {
- return 0;
- } else {
- return $row[0];
- } # unless
-} # count_distinct
-
-sub countlog(;$) {
- my ($additional_condition) = @_;
-
- my $condition = "userid=\'$userid\' ";
-
- $condition .= "and $additional_condition" if $additional_condition;
-
- return count_distinct('log', 'sender', $condition);
-} # countlog
-
1;
use strict;
use warnings;
-use FindBin;
+use base qw(Exporter);
use MAPS;
-use MAPSUtil;
-use vars qw(@ISA @EXPORT);
-use Exporter;
+use DateUtils;
+use Utils;
-@ISA = qw (Exporter);
-
-@EXPORT = qw (
+our @EXPORT = qw (
Debug
Error
GetStats
Info
Logmsg
- getstats
@Types
);
return FindEmail($sender);
} # nbr_msgs
-sub GetStats(;$$) {
- my ($nbr_days, $date) = @_;
+sub GetStats(%) {
+ my (%params) = @_;
+
+ CheckParms(['userid'], \%params);
- $nbr_days ||= 1;
- $date ||= Today2SQLDatetime();
+ $params{days} ||= 1;
+ $params{date} ||= Today2SQLDatetime;
my %dates;
- while ($nbr_days > 0) {
- my $ymd = substr $date, 0, 10;
+ while ($params{days} > 0) {
+ my $ymd = substr $params{date}, 0, 10;
my $sod = $ymd . ' 00:00:00';
my $eod = $ymd . ' 23:59:59';
for (@Types) {
my $condition = "type=\'$_\' and (timestamp > \'$sod\' and timestamp < \'$eod\')";
- # Not sure why I need to qualify countlog
- $stats{$_} = MAPS::countlog($condition);
+ $stats{$_} = MAPS::CountLog(
+ userid => $params{userid},
+ additional => $condition,
+ );
} # for
$dates{$ymd} = \%stats;
- $date = SubtractDays $date, 1;
- $nbr_days--;
+ $params{date} = SubtractDays $params{date}, 1;
+ $params{days}--;
} # while
return %dates
} # GetStats
-sub Logmsg($$$) {
- my ($type, $sender, $msg) = @_;
+sub Logmsg(%) {
+ my(%params) = @_;
- # Todo: Why do I need to specify MAPS:: here?
- MAPS::AddLog($type, $sender, $msg);
+ CheckParms(['userid', 'type', 'message'], \%params);
- return;
+ # TODO Why do I need to qualify this?
+ return MAPS::AddLog(%params);
} # logmsg
-sub Debug($) {
- my ($msg) = @_;
-
- Logmsg('debug', '', $msg);
+sub Debug(%) {
+ my (%params) = @_;
- return;
+ return Logmsg(
+ userid => $params{userid},
+ type => 'debug',
+ message => $params{message});
} # Debug
-sub Error($) {
- my ($msg) = @_;
-
- Logmsg('error', '', $msg);
-
- return;
-} # Error
+sub Error(%) {
+ my (%params) = @_;
-sub Info($) {
- my ($msg) = @_;
+ return Logmsg(
+ userid => $params{userid},
+ type => 'error',
+ message => $params{message});
+ } # Error
- Logmsg('info', '', $msg);
+sub Info(%) {
+ my (%params) = @_;
- return;
+ return Logmsg(
+ userid => $params{userid},
+ type => 'info',
+ message => $params{message});
} # info
1;
+++ /dev/null
-#!/usr/bin/perl
-################################################################################
-#
-# File: $RCSfile: MAPSUtil.pm,v $
-# Revision: $Revision: 1.1 $
-# Description: MAPS Utilities
-# Author: Andrew@DeFaria.com
-# Created: Fri Nov 29 14:17:21 2002
-# Modified: $Date: 2013/06/12 14:05:47 $
-# Language: perl
-#
-# (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-package MAPSUtil;
-
-use strict;
-use warnings;
-
-use vars qw (@ISA @EXPORT);
-
-# Not sure why I was setting TZ to LA but I'm in Phoenix now. This is best
-# handled by configuring the OS correctly anyway.
-#BEGIN {
-# $ENV{TZ}='America/Los_Angeles';
-#} # BEGIN
-
-@ISA = qw (Exporter);
-
-@EXPORT = qw(
- CheckEmail
- FormatDate
- FormatTime
- SQLDatetime2UnixDatetime
- SubtractDays
- Today2SQLDatetime
- UnixDatetime2SQLDatetime
-);
-
-sub Today2SQLDatetime;
-
-sub FormatDate($) {
- my ($date) = @_;
-
- return substr ($date, 5, 2) . '/' .
- substr ($date, 8, 2) . '/' .
- substr ($date, 0, 4);
-} # FormatDate
-
-sub FormatTime($) {
- my ($time) = @_;
-
- my $hours = substr $time, 0, 2;
-
- $hours = substr $hours, 1, 1 if $hours < 10;
-
- my $minutes = substr $time, 3, 2;
- my $seconds = substr $time, 6, 2;
- my $AmPm = $hours > 12 ? 'Pm' : 'Am';
-
- $hours = $hours - 12 if $hours > 12;
-
- return "$hours:$minutes:$seconds $AmPm";
-} # FormatTime
-
-sub SQLDatetime2UnixDatetime($) {
- my ($sqldatetime) = @_;
-
- my %months = (
- '01' => 'Jan',
- '02' => 'Feb',
- '03' => 'Mar',
- '04' => 'Apr',
- '05' => 'May',
- '06' => 'Jun',
- '07' => 'Jul',
- '08' => 'Aug',
- '09' => 'Sep',
- '10' => 'Oct',
- '11' => 'Nov',
- '12' => 'Dec',
- );
-
- my $year = substr $sqldatetime, 0, 4;
- my $month = substr $sqldatetime, 5, 2;
- my $day = substr $sqldatetime, 8, 2;
- my $time = FormatTime substr $sqldatetime, 11;
-
- return $months {$month} . " $day, $year \@ $time";
-} # SQLDatetime2UnixDatetime
-
-sub SubtractDays($$) {
- my ($timestamp,$nbr_of_days) = @_;
-
- my @months = (
- 31, # January
- 28, # February
- 31, # March
- 30, # April
- 31, # May
- 30, # June
- 31, # July
- 31, # August
- 30, # September
- 31, # October
- 30, # November
- 31 # Descember
- );
-
- my $year = substr $timestamp, 0, 4;
- my $month = substr $timestamp, 5, 2;
- my $day = substr $timestamp, 8, 2;
-
- # Convert to Julian
- my $days = 0;
- my $m = 1;
-
- for (@months) {
- last if $m >= $month;
- $m++;
- $days += $_;
- } # for
-
- # Subtract $nbr_of_days
- $days += $day - $nbr_of_days;
-
- # Compute $days_in_year
- my $days_in_year = (($year % 4) == 0) ? 366 : 365;
-
- # Adjust if crossing year boundary
- if ($days <= 0) {
- $year--;
- $days = $days_in_year + $days;
- } # if
-
- # Convert back
- $month = 0;
-
- while ($days > 28) {
- # If remaining days is less than the current month then last
- last if ($days <= $months[$month]);
-
- # Subtract off the number of days in this month
- $days -= $months[$month++];
- } # while
-
- # Prefix month with 0 if necessary
- $month++ unless $month == 12;
- if ($month < 10) {
- $month = '0' . $month;
- } # if
-
- # Prefix days with 0 if necessary
- if ($days == 0) {
- $days = '01';
- } elsif ($days < 10) {
- $days = '0' . $days;
- } # if
-
- return $year . '-' . $month . '-' . $days . substr $timestamp, 10;
-} # SubtractDays
-
-sub UnixDatetime2SQLDatetime($) {
- my ($datetime) = @_;
-
- my $orig_datetime = $datetime;
- my %months = (
- 'Jan' => '01',
- 'Feb' => '02',
- 'Mar' => '03',
- 'Apr' => '04',
- 'May' => '05',
- 'Jun' => '06',
- 'Jul' => '07',
- 'Aug' => '08',
- 'Sep' => '09',
- 'Oct' => '10',
- 'Nov' => '11',
- 'Dec' => '12',
- );
-
- # Some mailers neglect to put the leading day of the week field in.
- # Check for this and compensate.
- my $dow = substr $datetime, 0, 3;
-
- if ($dow ne 'Mon' &&
- $dow ne 'Tue' &&
- $dow ne 'Wed' &&
- $dow ne 'Thu' &&
- $dow ne 'Fri' &&
- $dow ne 'Sat' &&
- $dow ne 'Sun') {
- $datetime = 'XXX, ' . $datetime;
- } # if
-
- # Some mailers have day before month. We need to correct this
- my $day = substr $datetime, 5, 2;
-
- if ($day =~ /\d /) {
- $day = '0' . (substr $day, 0, 1);
- $datetime = (substr $datetime, 0, 5) . $day . (substr $datetime, 6);
- } # if
-
- if ($day !~ /\d\d/) {
- $day = substr $datetime, 8, 2;
- } # if
-
- # Check for 1 digit date
- if ((substr $day, 0, 1) eq ' ') {
- $day = '0' . (substr $day, 1, 1);
- $datetime = (substr $datetime, 0, 8) . $day . (substr $datetime, 10);
- } # if
-
- my $year = substr $datetime, 20, 4;
-
- if ($year !~ /\d\d\d\d/) {
- $year = substr $datetime, 12, 4;
- if ($year !~ /\d\d\d\d/) {
- $year = substr $datetime, 12, 2;
- } #if
- } # if
-
- # Check for 2 digit year. Argh!
- if (length $year == 2 or (substr $year, 2, 1) eq ' ') {
- $year = '20' . (substr $year, 0, 2);
- $datetime = (substr $datetime, 0, 12) . '20' . (substr $datetime, 12);
- } # if
-
- my $month_name = substr $datetime, 4, 3;
-
- if (!defined $months {$month_name}) {
- $month_name = substr $datetime, 8, 3;
- } # if
- my $month = $months {$month_name};
-
- my $time = substr $datetime, 11, 8;
-
- if ($time !~ /\d\d:\d\d:\d\d/) {
- $time = substr $datetime, 17, 8
- } # if
-
- if (!defined $year) {
- print "WARNING: Year undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
- if (!defined $month) {
- print "Month undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
- if (!defined $day) {
- print "Day undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
- if (!defined $time) {
- print "Time undefined for $orig_datetime\nReturning today's date\n";
- return Today2SQLDatetime;
- } # if
-
- return "$year-$month-$day $time";
-} # UnixDatetime2SQLDatetime
-
-sub Today2SQLDatetime() {
- return UnixDatetime2SQLDatetime(scalar localtime);
-} # Today2SQLDatetime
-
-sub CheckEmail($$) {
- my ($username, $domain) = @_;
-
- # Check to see if a full email address in either $username or $domain
- if ($username eq '') {
- return '' if $domain eq '';
-
- if ($domain =~ /(.*)\@(.*)/) {
- ($username, $domain) = split '@', $domain;
- } # if
- } elsif ($domain eq '') {
- if ($username =~ /(.*)\@(.*)/) {
- ($username, $domain) = split '@', $username;
- } # if
- } # if
-
- return lc "$username\@$domain";
-} # CheckEmail
-
-1;
package MAPSWeb;
use strict;
-#use warnings;
+use warnings;
-use MAPS;
-use MAPSLog;
-use MAPSUtil;
+use base qw(Exporter);
-use CGI qw (:standard *table start_Tr end_Tr start_div end_div);
-use vars qw (@ISA @EXPORT);
+use DateUtils;
-use Exporter;
+use MAPS;
+use MAPSLog;
-@ISA = qw (Exporter);
+use CGI qw(:standard *table start_Tr end_Tr start_div end_div);
-@EXPORT = qw (
- Debug
+our @EXPORT = qw(
+ DebugWeb
DisplayError
Footing
Heading
NavigationBar
);
-sub getquickstats($) {
- my ($date) = @_;
+sub getquickstats(%) {
+ my (%params) = @_;
+
+ my %dates = GetStats(
+ userid => $params{userid},
+ days => 1,
+ date => $params{date},
+ );
- my %dates = GetStats (1, $date);
+ my $date = $params{date};
for (@MAPSLog::Types) {
$dates{$date}{processed} += $dates{$date}{$_};
return %dates;
} # getquickstats
-sub displayquickstats() {
+sub displayquickstats($) {
+ my ($userid) = @_;
+
# Quick stats are today only.
my $today = Today2SQLDatetime;
my $time = substr $today, 11;
my $date = substr $today, 0, 10;
- my %dates = getquickstats $date;
+ my %dates = getquickstats(
+ userid => $userid,
+ date => $date
+ );
print start_div {-class => 'quickstats'};
- print h4 {-class => 'header',
+ print h4 {-class => 'todaysactivity',
-align => 'center'},
'Today\'s Activity';
print p {-align => 'center'},
- b ('as of ' . FormatTime ($time));
+ b ('as of ' . FormatTime($time));
print start_table {
-align => 'center',
-border => 0,
return;
} # Footing
-sub Debug($) {
+sub DebugWeb($) {
my ($msg) = @_;
- print br, font ({ -class => 'error' }, 'DEBUG: '), $msg;
+ print br, font({ -class => 'error' }, 'DEBUG: '), $msg;
return;
} # Debug
sub DisplayError($) {
my ($errmsg) = @_;
- print h3 ({-class => 'error',
- -align => 'center'}, 'ERROR: ' . $errmsg);
+ print h3({
+ -class => 'error',
+ -align => 'center'},
+ 'ERROR: ' . $errmsg
+ );
Footing;
# This subroutine puts out the header for web pages. It is called by
# various cgi scripts thus has a few parameters.
sub Heading($$$$;$$@) {
- my ($action, # One of getcookie, setcookie, unsetcookie
- $userid, # User id (if setting a cookie)
- $title, # Title string
- $h1, # H1 header
- $h2, # H2 header (optional)
- $table_name, # Name of table in page, if any
- @scripts) = @_; # Array of JavaScript scripts to include
+ my ($action, # One of getcookie, setcookie, unsetcookie
+ $userid, # User id (if setting a cookie)
+ $title, # Title string
+ $h1, # H1 header
+ $h2, # H2 header (optional)
+ $table_name, # Name of table in page, if any
+ @scripts) = @_; # Array of JavaScript scripts to include
my @java_scripts;
my $cookie;
);
} # if
- print
- header (-title => "MAPS: $title",
- -cookie => $cookie);
-
- if (defined $table_name) {
- print
- start_html (-title => "MAPS: $title",
- -author => 'Andrew\@DeFaria.com',
- -style => {-src => '/maps/css/MAPSStyle.css'},
- -onResize => "AdjustTableWidth (\"$table_name\");",
- -head => [
- Link ({-rel => 'icon',
- -href => '/maps/MAPS.png',
- -type => 'image/png'}),
- Link ({-rel => 'shortcut icon',
- -href => '/maps/favicon.ico'})
- ],
- -script => @java_scripts);
+ print header(
+ -title => $title,
+ -cookie => $cookie
+ );
+
+ if ($table_name) {
+ print start_html(
+ -title => $title,
+ -author => 'Andrew\@DeFaria.com',
+ -style => {-src => '/maps/css/MAPSStyle.css'},
+ -onResize => "AdjustTableWidth (\"$table_name\");",
+ -head => [
+ Link({-rel => 'icon',
+ -href => '/maps/MAPS.png',
+ -type => 'image/png'}),
+ Link({-rel => 'shortcut icon',
+ -href => '/maps/favicon.ico'})
+ ],
+ -script => @java_scripts);
} else {
- print
- start_html (-title => "MAPS: $title",
- -author => 'Andrew\@DeFaria.com',
- -style => {-src => '/maps/css/MAPSStyle.css'},
- -head => [
- Link ({-rel => 'icon',
- -href => '/maps/MAPS.png',
- -type => 'image/png'}),
- Link ({-rel => 'shortcut icon',
- -href => '/maps/favicon.ico'})],
- -script => @java_scripts);
+ print start_html(
+ -title => $title,
+ -author => 'Andrew\@DeFaria.com',
+ -style => {-src => '/maps/css/MAPSStyle.css'},
+ -head => [
+ Link({-rel => 'icon',
+ -href => '/maps/MAPS.png',
+ -type => 'image/png'}),
+ Link({-rel => 'shortcut icon',
+ -href => '/maps/favicon.ico'})],
+ -script => @java_scripts);
} # if
print start_div {class => 'heading'};
- print h2 {-align => 'center',
- -class => 'header'},
- font ({-class => 'standout'}, 'MAPS'),
- $h1;
+ print h2 {
+ -align => 'center',
+ -class => 'header'}, $h1;
if (defined $h2 && $h2 ne '') {
- print h3 {-align => 'center',
- -class => 'header'},
- $h2;
+ print h3 {
+ -align => 'center',
+ -class => 'header'}, $h2;
} # if
print end_div;
print start_div {-id => 'leftbar'};
- if (!defined $userid) {
+ unless ($userid) {
+ print h2({-align => 'center'}, font({-color => 'white'}, "MAPS $MAPS::Version"));
print div ({-class => 'username'}, 'Welcome to MAPS');
print div ({-class => 'menu'},
(a {-href => '/maps/doc/'},
'Help<br>'),
);
} else {
+ print h2({-align => 'center'}, font({-color => 'white'}, "MAPS $MAPS::Version"));
print div ({-class => 'username'}, 'Welcome '. ucfirst $userid);
+
print div ({-class => 'menu'},
(a {-href => '/maps/'},
'Home<br>'),
(a {-href => '/maps/?logout=yes'},
'Logout'),
);
+
+ displayquickstats($userid);
+
print start_div {-class => 'search'};
print start_form {-method => 'get',
-action => '/maps/bin/search.cgi',
print end_form;
print end_div;
- displayquickstats;
-
print start_div {-class => 'search'};
print start_form {-method => 'post',
-action => 'javascript://',
-maxlength => 255,
-value => '',
-onclick => "document.address.email.value = '';"};
+ print p "";
print end_form;
print end_div;
} # if
print end_div;
+
+ return;
} # NavigationBar
1;
+++ /dev/null
-################################################################################
-#
-# MAPS: Mail Authorization and Permission System (MAPS)
-# null.list: Default null.list file
-# Exported: Thu Jan 15 16:22:16 2004
-#
-# Copyright 2001-2004, Andrew@DeFaria.com, all rights reserved.
-#
-################################################################################
-mdaemon@,Mailer bounces
-postauto@,Mailer bounces
-postbot@aol.net,Mailer bounces
-postdaemon@,Mailer bounces
-postengine@,Mailer bounces
-postform@,Mailer bounces
-postmaster@,Mailer bounces
-postprogram@,Mailer bounces
-postrobot@,Mailer bounces
-postroutine@,Mailer bounces
-postservice@,Mailer bounces
-smtpautomat@,Mailer bounces
-smtpbot@,Mailer bounces
-smtpdaemon@,Mailer bounces
-smtpengine@,Mailer bounces
-smtpform@,Mailer bounces
-smtpprogram@,Mailer bounces
-smtprobot@,Mailer bounces
-smtproutine@,Mailer bounces
-smtpservice@,Mailer bounces
-specials@,Mailer bounces
-superdeal@,Mailer bounces
-superspecial@,Mailer bounces
-webautomat@,Mailer bounces
-webbot@,Mailer bounces
-webdaemon@,Mailer bounces
-webengine@,Mailer bounces
-webform@,Mailer bounces
-webjump@defaria.com,Webjump
-webrobot@,Mailer bounces
-webroutine@,Mailer bounces
-yahoo mail@,Mailer bounces
-<?php \r
+<?php\r
////////////////////////////////////////////////////////////////////////////////\r
//\r
// File: $RCSFile$\r
<body>\r
\r
<div class="heading">\r
- <h2 class="header" align="center">\r
- <font class="standout">MAPS</font> Password Retrieval</h2>\r
+ <h2 class="header" align="center">Password Retrieval</h2>\r
</div>\r
\r
<div class="content">\r
-<?php \r
+<?php\r
////////////////////////////////////////////////////////////////////////////////\r
//\r
// File: $RCSFile$\r
</head>\r
<body>\r
<div class="heading">\r
-<h2 class="header" align="center"><font class="standout">MAPS</font>\r
-Returned Messages by Domain</h2>\r
+<h2 class="header" align="center">Returned Messages by Domain</h2>\r
</div>\r
<div class="content">\r
<?php\r
function OpenDB() {
global $db;
- $db = mysqli_connect("localhost", "maps", "spam")
+ $db = mysqli_connect("127.0.0.1", "maps", "spam")
or DBError("OpenDB: Unable to connect to database server", "Connect");
mysqli_select_db($db, "MAPS")
function Encrypt($password, $userid) {
global $db;
- $statement = "select encode(\"$password\",\"$userid\")";
+ $statement = "select hex(aes_encrypt(\"$password\",\"$userid\"))";
$result = mysqli_query($db, $statement)
or DBError("Encrypt: Unable to execute statement", $statement);
// Check if user exists
$dbpassword = UserExists($userid);
+ print "dbpassword = $dbpassword<br>";
// Return -1 if user doesn't exist
if ($dbpassword == -1) {
// Start quickstats
print "<div class=quickstats>";
- print "<h4 align=center class=header>Today's Activity</h4>";
+ print "<h4 align=center class=todaysactivity>Today's Activity</h4>";
print "<p align=center><b>as of $current_time</b></p>";
$processed = $dates[$today]["processed"];
if (!isset ($userid) || $userid == "") {
print <<<END
- <div class="username">Welcome to MAPS</div>
+ <h2 align='center'><font style="color: white">MAPS 2.0</font></h2>
+ <div class="username">Welcome to MAPS</div>
<div class="menu">
<a href="/maps/doc/">What is MAPS?</a><br>
<a href="/maps/doc/SPAM.php">What is SPAM?</a><br>
} else {
$Userid = ucfirst($userid);
print <<<END
- <div class="username">Welcome $Userid</div>
+ <h2 align='center'><font style="color: white">MAPS 2.0</font></h2>
+ <div class="username">Welcome $Userid</div>
<div class="menu">
<a href="/maps/">Home</a><br>
<a href="/maps/bin/stats.cgi">Statistics</a><br>
<a href="/maps/?logout=yes">Logout</a>
</div>
END;
+
+ displayquickstats();
+
print <<<END
<div class="search">
<form method="get" action="/maps/bin/search.cgi" name="search">
</div>
END;
- displayquickstats();
-
print <<<END
<div class="search">
<form "method"=post action="javascript://" name="address"
<input type="text" class="searchfield" id="searchfield" name="email"
size="20" maxlength="255" value="" onclick="document.address.email.value = '';">
</form>
+ <p></p>
</div>
END;
} // if
$domain = $row["domain"] == "" ? " " : $row["domain"];
$hit_count = $row["hit_count"] == "" ? " " : $row["hit_count"];
$last_hit = $row["last_hit"] == "" ? " " : $row["last_hit"];
+ $retention = $row["retention"] == "" ? " " : $row["retention"];
$comments = $row["comment"] == "" ? " " : $row["comment"];
// Remove time from last hit
print "<td class=$dataclass align=left><a href=\"http://$domain\" target=_blank>$domain</a></td>";
print "<td class=$dataclass align=right>" . $hit_count . "</td>";
print "<td class=$dataclass align=center>" . $last_hit . "</td>";
+ print "<td class=$dataclass align=right>" . $retention . "</td>";
print "<td class=$rightclass align=left>" . $comments . "</td>";
print "</tr>";
} // for
if ($i < $top - 1) {
print "<td class=tableleftdata align=center><input type=checkbox name=action" . $i . " value=on></td>\n";
print "<td align=center class=tabledata>" . $ranking . "</td>";
- print "<td class=tabledata>$domain</td>";
+ print "<td class=tabledata><a href=\"http://$domain\">$domain</as></td>";
print "<input type=hidden name=email$i value=\"@$domain\">";
print "<td align=center class=tablerightdata>$nbr</td>";
} else {
print "<td class=tablebottomleft align=center><input type=checkbox name=action" . $i . " value=on></td>\n";
print "<td align=center class=tablebottomdata>" . $ranking . "</td>";
- print "<td class=tablebottomdata>$domain</td>";
+ print "<td class=tablebottomdata><a href=\"http://$domain\">$domain</a></td>";
print "<input type=hidden name=email$i value=\"@$domain\">";
print "<td align=center class=tablebottomright>$nbr</td>";
} // if
-<?php \r
+<?php\r
////////////////////////////////////////////////////////////////////////////////\r
//\r
// File: $RCSFile$\r
</head>\r
<body>\r
<div class="heading">\r
-<h2 class="header" align="center"><font class="standout">MAPS</font>\r
-Reports</h2>\r
+<h2 class="header" align="center">Reports</h2>\r
</div>\r
<div class="content">\r
<?php\r
-<?php
+<?php
////////////////////////////////////////////////////////////////////////////////
//
// File: $RCSFile$
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US">
<head>
<title>MAPS: Space Usage</title>
- <?php
+ <?php
MAPSHeader ();
$Userid = ucfirst ($userid);
?>
</head>
<body>
<div class="heading">
-<h2 class="header" align="center"><font class="standout">MAPS</font>
-Space Usage for <?php echo $Userid?></h2>
+<h2 class="header" align="center">Space Usage for <?php echo $Userid?></h2>
</div>
<div class="content">
<?php
NavigationBar ($userid);
$space = Space();
-
+
$one_meg = 1024 * 1024;
if ($space > $one_meg) {
$password = $row [password];
$subject = "Your MAPS Password";
-// Decode password
+// Decode password
$statement = "select decode(\"$password\",\"$userid\")";
$result = mysql_query ($statement);
<body>
<div class="heading">
- <h2 class="header" align="center">
- <font class="standout">MAPS</font> Password Retrieval</h2>
+ <h2 class="header" align="center">Password Retrieval</h2>
</div>
<div class="content">
<?php
////////////////////////////////////////////////////////////////////////////////
//
-// File: $RCSFile$
-// Revision: $Revision: 1.1 $
-// Description: Process lists
-// Author: Andrew@DeFaria.com
-// Created: Fri Nov 29 14:17:21 2002
-// Modified: $Date: 2013/06/12 14:05:48 $
-// Language: PHP
+// File: $RCSFile$
+// Revision: $Revision: 1.1 $
+// Description: Process lists
+// Author: Andrew@DeFaria.com
+// Created: Fri Nov 29 14:17:21 2002
+// Modified: $Date: 2013/06/12 14:05:48 $
+// Language: PHP
//
// (c) Copyright 2000-2006, Andrew@DeFaria.com, all rights reserved.
//
<title>MAPS: Manage <?php echo "$Type"?> List</title>
<script language="JavaScript1.2" src="/maps/JavaScript/ListActions.js"
type="text/javascript"></script>
-<?php
+<?php
// Connect to MySQL
-OpenDB ();
+OpenDB();
// Set User context
SetContext ($userid);
<body>
<div class="heading">
- <h2 class="header" align="center">
- <font class="standout">MAPS</font> Manage <?php echo "$Userid's "; echo $Type?> List</h2>
+ <h2 class="header" align="center">Manage <?php echo "$Userid's "; echo $Type?> List</h2>
</div>
<div class="content">
<?php NavigationBar ($userid)?>
<form method="post" action="/maps/bin/processaction.cgi" name="list">
<div align="center">
- <?php
+ <?php
if ($message != "") {
print "<center><font class=\"error\">$message</font></center>";
} // if
} // if
} // for
print "</select>";
- //print "next: $next last_page: $last_page";
- print " of <a href=\"/maps/php/list.php?type=$type&next=" .
+ print " of <a href=\"/maps/php/list.php?type=$type&next=" .
($last_page - 1) * $lines . "\">$last_page</a>";
?>
</div>
<div class="toolbar" align="center">
<?php
- $prev_button = $prev >= 0 ?
+ $prev_button = $prev >= 0 ?
"<a href=list.php?type=$type&next=$prev><img src=/maps/images/previous.gif border=0 alt=Previous align=middle accesskey=p></a>" : "";
$next_button = ($next + $lines) < $total ?
"<a href=list.php?type=$type&next=" . ($next + $lines) . "><img src=/maps/images/next.gif border=0 alt=Next align=middle accesskey=n></a>" : "";
<th class="tableheader">Domain</th>
<th class="tableheader">Hit Count</th>
<th class="tableheader">Last Hit</th>
+ <th class="tableheader">Retention</th>
<th class="tablerightend">Comments</th>
</tr>
<br>
</form>
<div align=center>
+ <form method="post" enctype="multipart/form-data"
+ action="/maps/bin/importlist.cgi?type=<?php echo $type?>">
<a href="/maps/bin/exportlist.cgi?type=<?php echo $type?>">
<input type=submit name=export value="Export List"></a>
- <a href="/maps/bin/importlist.cgi?type=<?php echo $type?>">
- <input type=submit name=import value="Import List"></a>
+ <input type="submit" value="Import List"></input>
+ <input type="file" id="list" name="filename"></input>
+ <input type="hidden" name="type" value="<?php echo $type?>"></input>
+ </form>
</div>
<?php copyright (2001)?>
-<?php
+<?php
////////////////////////////////////////////////////////////////////////////////
//
// File: $RCSFile$
<body>
<div class="heading">
- <h2 class="header" align="center">
- <font class="standout">MAPS</font> Spam Elimination</h2>
+ <h2 class="header" align="center">Spam Elimination</h2>
</div>
<div class="content">
projects / clearscm.git / commitdiff