X-Git-Url: https://defaria.com/gitweb/?a=blobdiff_plain;f=maps%2Fbin%2Fimportlist.cgi;h=743c3aa5e9ac241b25e35041a475f103ce0e9427;hb=ae9e57b169de143d2b8a7c761c3bf7394385e0d0;hp=495da1508c88e3ddfc9ab35238723b0a9175adbf;hpb=59e4b094ca914ea2ff06f07da91a6c201cc7e466;p=clearscm.git diff --git a/maps/bin/importlist.cgi b/maps/bin/importlist.cgi index 495da15..743c3aa 100755 --- a/maps/bin/importlist.cgi +++ b/maps/bin/importlist.cgi @@ -1,18 +1,56 @@ #!/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 + +=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 ] [-file ] + + 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; @@ -22,61 +60,92 @@ use lib "$FindBin::Bin/../lib"; 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 Onlist 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
"; + push @output, "Added $sender to ${Userid}'s ${type}list
"; $count++; } else { - print br "$pattern is already on your " . ucfirst($type) . 'list'; + push @output, "$sender is already on your " . ucfirst($type) . 'list
'; } # unless } # while - close $file; + print $_ for @output; return $count; } # importList @@ -88,13 +157,17 @@ GetOptions( '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', @@ -103,11 +176,14 @@ $userid = Heading( '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";