1252 lines
43 KiB
Perl
1252 lines
43 KiB
Perl
|
# ==================================================================
|
||
|
|
# Gossamer List - enhanced mailing list management system
|
||
|
|
#
|
||
|
|
# Website : http://gossamer-threads.com/
|
||
|
|
# Support : http://gossamer-threads.com/scripts/support/
|
||
|
|
# CVS Info :
|
||
|
|
# Revision : $Id: GList.pm,v 1.69 2004/10/14 22:57:50 bao Exp $
|
||
|
|
#
|
||
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||
|
|
# Redistribution in part or in whole strictly prohibited. Please
|
||
|
|
# see LICENSE file for full details.
|
||
|
|
# ==================================================================
|
||
|
|
#
|
||
|
|
|
||
|
|
package GList;
|
||
|
|
# ==================================================================
|
||
|
|
|
||
|
|
use 5.004_04;
|
||
|
|
use strict;
|
||
|
|
use GList::Custom; # Empty module for end-users to modify, if special code is
|
||
|
|
# required. Won't be overwritten when upgrading.
|
||
|
|
|
||
|
|
use vars qw($VERSION $DEBUG $IN $DB $CFG $USER $GLOBALS $GLOB_NO_SUBS $LANGUAGE $LANG_TPL $error @ISA @EXPORT_OK %EXPORT_TAGS $MN_SELECTED);
|
||
|
|
use GT::Base qw/:all/;
|
||
|
|
use GT::CGI;
|
||
|
|
use GT::Config;
|
||
|
|
use GT::Delay;
|
||
|
|
use GT::Template;
|
||
|
|
use GT::Plugins;
|
||
|
|
use GList::Config;
|
||
|
|
require Exporter;
|
||
|
|
|
||
|
|
$DEBUG = 0;
|
||
|
|
$VERSION = '1.1.1';
|
||
|
|
|
||
|
|
use constants
|
||
|
|
READ_SIZE => 65_536,
|
||
|
|
|
||
|
|
ADMINISTRATOR => 1,
|
||
|
|
LIMITED_USER => 2,
|
||
|
|
UNLIMITED_USER => 3,
|
||
|
|
UNVALIDATED_USER => 4,
|
||
|
|
|
||
|
|
TRACK_OPEN_HTML => <<HTML,
|
||
|
|
<img src="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>" width="1" height="1">
|
||
|
|
<iframe src="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>" width="1" height="1"></iframe>
|
||
|
|
<table border=0 cellpadding=0 cellspacing=0 height="1" width="1"><tr><td background="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>"></td></tr></table>
|
||
|
|
HTML
|
||
|
|
|
||
|
|
TRACK_OPEN_HTML_NOIFRAME => <<HTML,
|
||
|
|
<img src="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>" width="1" height="1">
|
||
|
|
<table border=0 cellpadding=0 cellspacing=0 height="1" width="1"><tr><td background="<%cgi_url%>/glist.cgi?do=user_open;eml_code=<%eml_code%>;mailing=<%mailing%>"></td></tr></table>
|
||
|
|
HTML
|
||
|
|
|
||
|
|
TRACK_CLICK_URL => "<%cgi_url%>/glist.cgi?do=user_click;mailing=<%mailing%>";
|
||
|
|
|
||
|
|
|
||
|
|
@ISA = 'Exporter';
|
||
|
|
@EXPORT_OK = qw/
|
||
|
|
$VERSION $MOD_PERL $DEBUG $IN $DB $CFG $USER $GLOBALS $LANGUAGE $MN_SELECTED
|
||
|
|
ADMINISTRATOR LIMITED_USER UNLIMITED_USER UNVALIDATED_USER TRACK_OPEN_HTML TRACK_OPEN_HTML_NOIFRAME TRACK_CLICK_URL
|
||
|
|
/;
|
||
|
|
%EXPORT_TAGS = (
|
||
|
|
all => \@EXPORT_OK,
|
||
|
|
objects => [qw/$IN $DB $CFG $USER $MN_SELECTED/],
|
||
|
|
user_type => [qw/ADMINISTRATOR LIMITED_USER UNLIMITED_USER UNVALIDATED_USER/],
|
||
|
|
tracks => [qw/TRACK_OPEN_HTML TRACK_OPEN_HTML_NOIFRAME TRACK_CLICK_URL/]
|
||
|
|
);
|
||
|
|
|
||
|
|
my $basic_tables;
|
||
|
|
|
||
|
|
sub init {
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# This subroutine should be called on every request with a single argument: the
|
||
|
|
# path to the private library directory.
|
||
|
|
#
|
||
|
|
|
||
|
|
# If called as a method, discard the class/object:
|
||
|
|
shift if @_ and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||
|
|
my $lib_path = shift || '.';
|
||
|
|
|
||
|
|
if (PERSIST) {
|
||
|
|
GT::SQL->reset_env() if $INC{'GT/SQL.pm'};
|
||
|
|
GT::Plugins->reset_env();
|
||
|
|
GT::CGI->reset_env();
|
||
|
|
}
|
||
|
|
|
||
|
|
# Get our config object.
|
||
|
|
$CFG = GList::Config->new($lib_path);
|
||
|
|
|
||
|
|
my $debug = $CFG->{debug_level} || $DEBUG;
|
||
|
|
|
||
|
|
# create input and sql objects
|
||
|
|
$IN = GT::CGI->new();
|
||
|
|
|
||
|
|
if ($DB and not ref $DB eq 'GT::Delay') {
|
||
|
|
$DB = GT::SQL->new({
|
||
|
|
def_path => "$CFG->{priv_path}/defs",
|
||
|
|
cache => 1,
|
||
|
|
debug => $debug
|
||
|
|
});
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$DB = GT::Delay(
|
||
|
|
'GT::SQL' => 'HASH',
|
||
|
|
{
|
||
|
|
def_path => "$CFG->{priv_path}/defs",
|
||
|
|
cache => 1,
|
||
|
|
debug => $debug
|
||
|
|
}
|
||
|
|
);
|
||
|
|
}
|
||
|
|
|
||
|
|
# Set plugin debug level.
|
||
|
|
$GT::Plugins::DEBUG = $debug;
|
||
|
|
|
||
|
|
$USER = $GLOBALS = $GLOB_NO_SUBS = $LANGUAGE = $LANG_TPL = $basic_tables = undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub init_user {
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Check to see if the request is for a valid user, if so, set $USER to the
|
||
|
|
# user.
|
||
|
|
#
|
||
|
|
|
||
|
|
# Authenticate the user.
|
||
|
|
require GList::Authenticate;
|
||
|
|
GList::Authenticate::auth('init');
|
||
|
|
|
||
|
|
$USER = undef;
|
||
|
|
|
||
|
|
my $username = shift || $IN->param('username') || undef;
|
||
|
|
my $password = shift || $IN->param('password') || undef;
|
||
|
|
|
||
|
|
# Validate the username, either through logging on, or checking the
|
||
|
|
# session.
|
||
|
|
my ($valid_user, $session_id, $use_cookie);
|
||
|
|
if (defined $username && defined $password) {
|
||
|
|
unless (test_connection()) { # Database connection is failed
|
||
|
|
if ( GList::Authenticate::auth('admin_valid_user', { username => $username, password => $password }) ) {
|
||
|
|
$USER->{username} = $username;
|
||
|
|
$USER->{usr_type} = ADMINISTRATOR;
|
||
|
|
return $USER;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif (GList::Authenticate::auth('valid_user', { username => $username, password => $password })) {
|
||
|
|
$valid_user = $username;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
unless (test_connection()) { # Database connection is failed
|
||
|
|
my $results = GList::Authenticate::auth('admin_valid_session');
|
||
|
|
if ($results) {
|
||
|
|
$USER = $results;
|
||
|
|
$USER->{usr_type} = ADMINISTRATOR;
|
||
|
|
return $USER;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
my $results = GList::Authenticate::auth('valid_session');
|
||
|
|
$valid_user = $results->{user_name};
|
||
|
|
$session_id = $results->{session_id};
|
||
|
|
$use_cookie = $results->{use_cookie};
|
||
|
|
}
|
||
|
|
return if !$valid_user;
|
||
|
|
|
||
|
|
# We have a valid_user, now let's get the user from database
|
||
|
|
$USER = GList::Authenticate::auth('get_user', { username => $valid_user });
|
||
|
|
return 1 if !$USER;
|
||
|
|
|
||
|
|
if ($CFG->{signup_email_validate} and $USER->{usr_validate_code}) {
|
||
|
|
return 2;
|
||
|
|
}
|
||
|
|
|
||
|
|
if ($CFG->{signup_admin_validate} and $USER->{usr_type} == UNVALIDATED_USER) {
|
||
|
|
return 3;
|
||
|
|
}
|
||
|
|
|
||
|
|
$USER->{use_cookie} = $use_cookie;
|
||
|
|
$USER->{session_id} = $session_id;
|
||
|
|
|
||
|
|
return $USER;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub test_connection {
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Test the database connection by trying to establish a connection. Returns
|
||
|
|
# 1 on success, nothing on connection error. In addition to the database
|
||
|
|
# connection, this also makes sure that the Users and Users_Sessions tables
|
||
|
|
# are working, since you need them at a minimum to get to the SQL setup page.
|
||
|
|
#
|
||
|
|
$DB->driver or return;
|
||
|
|
GT::SQL::Table->new(connect => $DB->{connect})->connect or return;
|
||
|
|
unless ($basic_tables) {
|
||
|
|
defined $DB->table('Users')->count({ usr_username => undef }) or return;
|
||
|
|
defined $DB->table('Users_Sessions')->count({ session_id => undef }) or return;
|
||
|
|
$basic_tables++;
|
||
|
|
}
|
||
|
|
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub environment {
|
||
|
|
# --------------------------------------------------------------------
|
||
|
|
# Return HTML formatted environment for error messages.
|
||
|
|
#
|
||
|
|
my $info = '<PRE>';
|
||
|
|
|
||
|
|
# Stack trace.
|
||
|
|
my $i = 0;
|
||
|
|
$info .= "<B>Stack Trace</B>\n======================================\n";
|
||
|
|
$info .= GT::Base::stack_trace('GList', 1);
|
||
|
|
$info .= "\n\n";
|
||
|
|
|
||
|
|
# Print GT::SQL error if it exists.
|
||
|
|
$info .= "<B>System Information</B>\n======================================\n";
|
||
|
|
$info .= "Perl Version: $]\n";
|
||
|
|
$info .= "GList SQL Version: $GList::VERSION\n" if ($GList::VERSION);
|
||
|
|
$info .= "DBI.pm Version: $DBI::VERSION\n" if ($DBI::VERSION);
|
||
|
|
$info .= "Running under mod_perl: " . (MOD_PERL ? "Yes (version " . MOD_PERL . ")" . (MOD_PERL >= 1.99 ? ', mod_perl 2 detected' : '') : "No") . "\n";
|
||
|
|
$info .= "Running under SpeedyCGI: " . (SPEEDY ? "Yes (version " . SPEEDY . ")" : "No") . "\n";
|
||
|
|
$info .= "GT::SQL::error = $GT::SQL::error\n" if ($GT::SQL::error);
|
||
|
|
$info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
|
||
|
|
$info .= "\$\@: $@\n" if ($@);
|
||
|
|
$info .= "\n";
|
||
|
|
|
||
|
|
# CGI Parameters and Cookies.
|
||
|
|
if (ref $IN eq 'GT::CGI') {
|
||
|
|
if ($IN->param) {
|
||
|
|
$info .= "<B>CGI INPUT</B>\n======================================\n";
|
||
|
|
foreach (sort $IN->param) { $info .= "$_ => " . $IN->param($_) . "\n"; }
|
||
|
|
$info .= "\n\n";
|
||
|
|
}
|
||
|
|
if ($IN->cookie) {
|
||
|
|
$info .= "<B>CGI Cookies</B>\n======================================\n";
|
||
|
|
foreach (sort $IN->cookie) { $info .= "$_ => " . $IN->cookie($_) . "\n"; }
|
||
|
|
$info .= "\n\n";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Environement info.
|
||
|
|
$info .= "<B>ENVIRONMENT</B>\n======================================\n";
|
||
|
|
foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
|
||
|
|
$info .= "</PRE>";
|
||
|
|
|
||
|
|
return $info;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub display {
|
||
|
|
# -----------------------------------------------------------------
|
||
|
|
# Returns a specified template parsed.
|
||
|
|
#
|
||
|
|
my ($template, $args) = @_;
|
||
|
|
|
||
|
|
my $template_set = $IN->param('t') || $CFG->{template_set};
|
||
|
|
my $template_dir = "$CFG->{priv_path}/templates/$template_set";
|
||
|
|
my $http = $IN->url(absolute => 0, query_string => 0);
|
||
|
|
|
||
|
|
# Add config vars.
|
||
|
|
foreach my $key (keys %$CFG) {
|
||
|
|
$args->{$key} = $CFG->{$key} unless (exists $args->{$key});
|
||
|
|
}
|
||
|
|
|
||
|
|
# Used for HTML editor
|
||
|
|
my %browser = $IN->browser_info;
|
||
|
|
delete $browser{is_ie} if $browser{is_ie} and $browser{ie_version} < 5.5;
|
||
|
|
@$args{keys %browser} = values %browser;
|
||
|
|
|
||
|
|
$args->{html}->{in} = $IN;
|
||
|
|
$args->{html}->{sql} = $DB;
|
||
|
|
$args->{html}->{cfg} = $CFG;
|
||
|
|
$args->{selected_menu} = $MN_SELECTED;
|
||
|
|
|
||
|
|
# Loads template globals
|
||
|
|
load_globals();
|
||
|
|
|
||
|
|
# Escapes HTML code
|
||
|
|
my $cgi = $IN->get_hash();
|
||
|
|
my $content = $cgi->{msg_content_html};
|
||
|
|
if ( $content ) {
|
||
|
|
$content =~ s,\r\n,\n,g;
|
||
|
|
$cgi->{msg_content_html} = $IN->html_escape($content);
|
||
|
|
}
|
||
|
|
|
||
|
|
unless (defined $args->{hidden_query}) {
|
||
|
|
my $hidden = hidden();
|
||
|
|
$args->{hidden_query} = $hidden->{hidden_query};
|
||
|
|
$args->{hidden_objects} = $hidden->{hidden_objects};
|
||
|
|
}
|
||
|
|
print $IN->header;
|
||
|
|
GT::Template->parse($template, [$args, $cgi, $GLOBALS, $USER || {}], { print => 1, root => $template_dir });
|
||
|
|
}
|
||
|
|
|
||
|
|
sub set_default_template {
|
||
|
|
#-----------------------------------------------------------
|
||
|
|
# Add default email template when adding a user
|
||
|
|
#
|
||
|
|
my ($fname, $userid) = @_;
|
||
|
|
require GT::Mail::Editor;
|
||
|
|
my $email = GT::Mail::Editor->new(dir => "$CFG->{priv_path}/templates", template => $CFG->{template_set});
|
||
|
|
$email->load($fname);
|
||
|
|
my $hsh = {};
|
||
|
|
my $cgi = $IN->get_hash();
|
||
|
|
|
||
|
|
$fname =~ s/\.eml//;
|
||
|
|
$hsh->{tpl_user_id_fk} = $userid;
|
||
|
|
$hsh->{tpl_name} = $fname;
|
||
|
|
$hsh->{tpl_to} = $email->{headers}->{To};
|
||
|
|
$hsh->{tpl_from} = $email->{headers}->{From};
|
||
|
|
$hsh->{tpl_subject}= $email->{headers}->{Subject};
|
||
|
|
$hsh->{tpl_body} = $email->{body};
|
||
|
|
|
||
|
|
$DB->table('EmailTemplates')->insert($hsh);
|
||
|
|
}
|
||
|
|
|
||
|
|
sub add {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
# Add a record
|
||
|
|
#
|
||
|
|
my ($table, $prefix, $cgi) = @_;
|
||
|
|
|
||
|
|
my $db = $DB->table($table) or return $GT::SQL::error;
|
||
|
|
|
||
|
|
# Turn arrays into delimited fields
|
||
|
|
$cgi ||= format_insert_cgi($db);
|
||
|
|
|
||
|
|
# Save the current time
|
||
|
|
if ( $table eq 'Messages' ) {
|
||
|
|
$cgi->{msg_created} = time;
|
||
|
|
if ($cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src="">\s*<\/BODY>\s*<\/html>\s*$/mi or
|
||
|
|
$cgi->{msg_content_html} =~ /^\s*<html>\s*<body\s*src="">\s*<\/body>\s*<\/html>\s*$/mi or
|
||
|
|
$cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src=""><p>\ <\/p><\/BODY>\s*<\/html>\s*$/mi or
|
||
|
|
$cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*src=""><P>\ <\/P><\/BODY>\s*<\/html>\s*$/mi) {
|
||
|
|
$cgi->{msg_content_html} = "";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif ( $table eq 'Lists' ) {
|
||
|
|
$cgi->{lst_date_created} = time;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Add the record's owner
|
||
|
|
$cgi->{$prefix.'_user_id_fk'} = $USER->{usr_username};
|
||
|
|
|
||
|
|
# Setup the language for GT::SQL.
|
||
|
|
local $GT::SQL::ERRORS->{ILLEGALVAL} = language('ADD_ILLEGALVAL') if ( language('ADD_ILLEGALVAL') );
|
||
|
|
local $GT::SQL::ERRORS->{UNIQUE} = language('ADD_UNIQUE') if ( language('ADD_UNIQUE') );
|
||
|
|
local $GT::SQL::ERRORS->{NOTNULL} = language('ADD_NOTNULL') if ( language('ADD_NOTNULL') );
|
||
|
|
|
||
|
|
my $cols = $db->cols;
|
||
|
|
|
||
|
|
foreach my $c ( keys % $cols ) {
|
||
|
|
my $regex = $cols->{$c}->{form_regex};
|
||
|
|
if ( $regex and $cgi->{$c} !~ /$regex/ ) {
|
||
|
|
$error .= language('SYS_REGEXFAIL', $cols->{$c}->{form_display});
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return if ( $error );
|
||
|
|
if ( defined (my $ret = $db->add($cgi)) ) {
|
||
|
|
return $ret;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
local $^W;
|
||
|
|
$error = $GT::SQL::error;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub modify {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
# Modify a record
|
||
|
|
#
|
||
|
|
my ($table, $prefix, $cgi) = @_;
|
||
|
|
|
||
|
|
my $db = $DB->table($table) or return $GT::SQL::error;
|
||
|
|
|
||
|
|
# Format arrays for insertion
|
||
|
|
$cgi ||= format_insert_cgi($db, $cgi);
|
||
|
|
|
||
|
|
# Check if users can modify only their own records except Administrator
|
||
|
|
if ( $USER->{usr_type} != ADMINISTRATOR ) {
|
||
|
|
my $lookup = {};
|
||
|
|
my $pk = $db->pk;
|
||
|
|
foreach (@$pk) { $lookup->{$_} = $IN->param($_); }
|
||
|
|
my $rs = $db->get($lookup);
|
||
|
|
|
||
|
|
if ( $rs->{$prefix.'_user_id_fk'} ne $USER->{usr_username} ) {
|
||
|
|
$error = language('SYS_PER_DENIED');
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Setup the language for GT::SQL.
|
||
|
|
local $GT::SQL::ERRORS->{ILLEGALVAL} = language('ADD_ILLEGALVAL') if ( language('ADD_ILLEGALVAL') );
|
||
|
|
local $GT::SQL::ERRORS->{UNIQUE} = language('ADD_UNIQUE') if ( language('ADD_UNIQUE') );
|
||
|
|
local $GT::SQL::ERRORS->{NOTNULL} = language('ADD_NOTNULL') if ( language('ADD_NOTNULL') );
|
||
|
|
|
||
|
|
if ( $table eq 'Messages' ) {
|
||
|
|
if ($cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src="">\s*<\/BODY>\s*<\/html>\s*$/mi or
|
||
|
|
$cgi->{msg_content_html} =~ /^\s*<html>\s*<body\s*src="">\s*<\/body>\s*<\/html>\s*$/mi or
|
||
|
|
$cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*class=object\s*\s*src=""><p>\ <\/p><\/BODY>\s*<\/html>\s*$/mi or
|
||
|
|
$cgi->{msg_content_html} =~ /^\s*<html>\s*<BODY\s*src=""><P>\ <\/P><\/BODY>\s*<\/html>\s*$/mi) {
|
||
|
|
$cgi->{msg_content_html} = "";
|
||
|
|
}
|
||
|
|
if ($cgi->{msg_mode} eq 'text') {
|
||
|
|
$cgi->{msg_content_html} = '';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if ( $db->modify($cgi) ) {
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
local $^W;
|
||
|
|
$error = $GT::SQL::error;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub delete {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
# Delete records
|
||
|
|
#
|
||
|
|
my ($table, $prefix, $cgi, $msg) = @_;
|
||
|
|
|
||
|
|
my $db = $DB->table($table);
|
||
|
|
|
||
|
|
# Create a cgi object
|
||
|
|
$cgi ||= $IN->get_hash();
|
||
|
|
|
||
|
|
# If they selected only one record to delete we still need an array ref
|
||
|
|
my $mod = ( ref $cgi->{modify} eq 'ARRAY' ) ? $cgi->{modify} : [$cgi->{modify}];
|
||
|
|
|
||
|
|
# Need to know the names of the columns for this Table.
|
||
|
|
my @columns = keys %{$db->cols};
|
||
|
|
|
||
|
|
# Need to know the number of records modified
|
||
|
|
my $rec_modified = 0;
|
||
|
|
my $rec_declined = 0;
|
||
|
|
|
||
|
|
|
||
|
|
if ( $table eq 'Messages' or $table eq 'MailingIndex' ) {
|
||
|
|
require GT::File::Tools;
|
||
|
|
}
|
||
|
|
|
||
|
|
# For through the record numbers. These are the values of the
|
||
|
|
# check boxes
|
||
|
|
foreach my $rec_num ( @{$mod} ) {
|
||
|
|
my $change = {};
|
||
|
|
foreach my $column ( @columns ) {
|
||
|
|
$change->{$column} = $cgi->{"$rec_num-$column"} if ( $cgi->{"$rec_num-$column"} );
|
||
|
|
}
|
||
|
|
|
||
|
|
# Check for delete own record
|
||
|
|
if ( $USER->{usr_type} != ADMINISTRATOR ) { # As a user
|
||
|
|
my $rs = $db->get($change);
|
||
|
|
next if ( !$rs );
|
||
|
|
if ( $rs->{$prefix.'_user_id_fk'} ne $USER->{usr_username} ) {
|
||
|
|
$rec_declined++; next;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
next unless ( keys %$change );
|
||
|
|
if ( $table eq 'MailingIndex' ) {
|
||
|
|
if ( int $cgi->{fd} and $cgi->{fd} == 3 ) { # Deletes records
|
||
|
|
my $info = $db->get($change) || {};
|
||
|
|
if ( $USER->{usr_type} == ADMINISTRATOR or !$info->{mli_Done} ) { # Admin user
|
||
|
|
my $ret = $db->delete($change);
|
||
|
|
if ( defined $ret and ($ret != 0) ) {
|
||
|
|
$rec_modified++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$db->update({ mli_delete => '2', mli_cat_id_fk => 0, mli_root => '0' }, $change);
|
||
|
|
$rec_modified++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else { # Marks records
|
||
|
|
$db->update({ mli_delete => '1', mli_cat_id_fk => 0, mli_root => '0' }, $change);
|
||
|
|
$rec_modified++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $ret = $db->delete($change) or die $GT::SQL::error;
|
||
|
|
if ( defined $ret and ($ret != 0) ) {
|
||
|
|
$rec_modified++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
# Remove attachments
|
||
|
|
my $id = $IN->param("$rec_num-msg_id");
|
||
|
|
if ( $table eq 'Messages' and $id ) {
|
||
|
|
remove_attachments($id, 'messages');
|
||
|
|
}
|
||
|
|
|
||
|
|
$id = $IN->param("$rec_num-Mailing");
|
||
|
|
if ( $table eq 'MailingIndex' and $id and $cgi->{fd} == 3 ) {
|
||
|
|
remove_attachments($id, 'mailings');
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$msg ||= ( $rec_declined ) ? GList::language('SYS_DELETED2', $rec_modified, $rec_declined) : GList::language('SYS_DELETED', $rec_modified);
|
||
|
|
return $msg;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub send {
|
||
|
|
#--------------------------------------------------------
|
||
|
|
# Send a message by using GT::Mail
|
||
|
|
#
|
||
|
|
my ($head, $content, $attachments, $attach_path, $charset) = @_;
|
||
|
|
|
||
|
|
$attachments ||= [];
|
||
|
|
$charset ||= 'us-ascii';
|
||
|
|
require GT::Mail;
|
||
|
|
$GT::Mail::error ||= ''; # Silence -w
|
||
|
|
|
||
|
|
my $m = GT::Mail->new(debug => $CFG->{debug_level}, header_charset => $charset);
|
||
|
|
my $parts;
|
||
|
|
if ( $content->{text} and $content->{html} ) {
|
||
|
|
$parts = $m->new_part('Content-Type' => "multipart/alternative; charset=\"$charset\"");
|
||
|
|
$parts->parts($m->new_part(
|
||
|
|
'Content-Type' => "text/plain; charset=\"$charset\"",
|
||
|
|
body_data => $content->{text},
|
||
|
|
encoding => 'quoted-printable'
|
||
|
|
));
|
||
|
|
$parts->parts($m->new_part(
|
||
|
|
'Content-Type' => "text/html; charset=\"$charset\"",
|
||
|
|
body_data => $content->{html},
|
||
|
|
encoding => 'quoted-printable'
|
||
|
|
));
|
||
|
|
}
|
||
|
|
elsif (@$attachments) {
|
||
|
|
my $msg = $content->{text} || $content->{html};
|
||
|
|
my $type = ( $msg =~ m/(<html>|<body>)/i ? "text/html" : "text/plain" );
|
||
|
|
$type = "text/html" if ($content->{html});
|
||
|
|
$parts = $m->new_part(
|
||
|
|
'Content-Type' => "$type; charset=\"$charset\"",
|
||
|
|
body_data => $msg,
|
||
|
|
encoding => 'quoted-printable'
|
||
|
|
);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $msg = $content->{text} || $content->{html};
|
||
|
|
my $type = ( $msg =~ m/(<html>|<body>)/i ? "text/html" : "text/plain" );
|
||
|
|
$type = "text/html" if ($content->{html});
|
||
|
|
$parts = $m->new_part(
|
||
|
|
'Content-Type' => "$type; charset=\"$charset\"",
|
||
|
|
encoding => 'quoted-printable'
|
||
|
|
);
|
||
|
|
$head->{body_data} = $msg;
|
||
|
|
}
|
||
|
|
|
||
|
|
# Handle the attachments
|
||
|
|
if (@$attachments) {
|
||
|
|
my $apart = $m->new_part('Content-Type' => 'multipart/mixed');
|
||
|
|
$apart->parts($parts);
|
||
|
|
for (@$attachments) {
|
||
|
|
my $id = $_->{att_id} || $_->{mat_id};
|
||
|
|
my $filename = $_->{mat_file_name} || $_->{att_file_name};
|
||
|
|
my $content_type = _load_mime("$attach_path/$id", $filename);
|
||
|
|
$apart->parts($m->new_part(
|
||
|
|
body_path => "$attach_path/$id",
|
||
|
|
encoding => '-guess',
|
||
|
|
filename => $filename,
|
||
|
|
'Content-Type' => $content_type
|
||
|
|
));
|
||
|
|
}
|
||
|
|
$parts = $apart;
|
||
|
|
}
|
||
|
|
|
||
|
|
$head->{'Content-Type'} = $parts->get('Content-Type');
|
||
|
|
|
||
|
|
my $mail = GT::Mail->new(
|
||
|
|
%$head,
|
||
|
|
debug => $CFG->{debug_level},
|
||
|
|
header_charset => $charset,
|
||
|
|
);
|
||
|
|
for ($parts->parts()) {
|
||
|
|
$mail->attach($_);
|
||
|
|
}
|
||
|
|
|
||
|
|
$mail->send(
|
||
|
|
smtp => $CFG->{smtp_server},
|
||
|
|
sendmail => $CFG->{mail_path},
|
||
|
|
) or warn $GT::Mail::error;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub hidden {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
#
|
||
|
|
my $args = shift || [];
|
||
|
|
|
||
|
|
push @$args, 'users';
|
||
|
|
my $cgi = $IN->get_hash();
|
||
|
|
my ($hidden_query, $hidden_objects) = ('', '');
|
||
|
|
if ($CFG->{user_session} and ($cgi->{sid} or $USER->{session_id})) {
|
||
|
|
my $session_id = $cgi->{sid} || $USER->{session_id};
|
||
|
|
$hidden_query = ";sid=$session_id";
|
||
|
|
$hidden_objects = qq!<input type="hidden" name="sid" value="$session_id">!;
|
||
|
|
}
|
||
|
|
foreach (@$args) {
|
||
|
|
next unless $cgi->{$_};
|
||
|
|
$hidden_query .= ";$_=$cgi->{$_};$_-opt==";
|
||
|
|
$hidden_objects .= qq!<input type="hidden" name="$_" value="$cgi->{$_}">
|
||
|
|
<input type="hidden" name="$_-opt" value="=">
|
||
|
|
!;
|
||
|
|
}
|
||
|
|
return { hidden_query => $hidden_query, hidden_objects => $hidden_objects };
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _search_check {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
#
|
||
|
|
my ($cols, $cgi) = @_;
|
||
|
|
foreach (keys % $cols) {
|
||
|
|
my ($c) = $_ =~ /\.([^.]+)$/;
|
||
|
|
$c ||= $_;
|
||
|
|
if (exists $cgi->{$c} and $cgi->{$c}) {
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
if ($cgi->{"$c-ge"} or $cgi->{"$c-le"} or $cgi->{"$c-gt"} or $cgi->{"$c-lt"}) {
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub search {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
# Search engine
|
||
|
|
#
|
||
|
|
my $opts = ref $_[0] eq 'HASH' ? shift : { @_ };
|
||
|
|
my $cgi = $opts->{cgi};
|
||
|
|
my $db = $opts->{db};
|
||
|
|
my $prefix = $opts->{prefix};
|
||
|
|
my $based_on = $opts->{based_on};
|
||
|
|
my $skip_user = $opts->{skip_user};
|
||
|
|
my $search_check= $opts->{search_check};
|
||
|
|
my $search_alpha= $opts->{search_alpha};
|
||
|
|
my $search_col = $opts->{search_col};
|
||
|
|
my $return_msg = $opts->{return_msg};
|
||
|
|
my $select_all = $opts->{select_all};
|
||
|
|
my $show_user = $opts->{show_user};
|
||
|
|
my $int_field = $opts->{int_field};
|
||
|
|
$return_msg ||= uc($prefix).'_RESULTS';
|
||
|
|
|
||
|
|
my $user_field = $prefix."_user_id_fk";
|
||
|
|
my $nh = $cgi->{nh} || 1;
|
||
|
|
my $mh = $cgi->{mh} || 25;
|
||
|
|
my $ma = $cgi->{ma} || '';
|
||
|
|
my $bg = ( $nh == 1 ) ? 0 : ( $nh - 1 ) * $mh;
|
||
|
|
my $sb = $cgi->{sb} || $opts->{sb};
|
||
|
|
my $so = $cgi->{so} || $opts->{so};
|
||
|
|
my $cols = $db->cols;
|
||
|
|
my $table_name = $db->name;
|
||
|
|
my $db_prefix = $DB->prefix;
|
||
|
|
$table_name =~ s/^$db_prefix//;
|
||
|
|
|
||
|
|
$sb ||= $opts->{sb};
|
||
|
|
$so ||= $opts->{so} || 'ASC';
|
||
|
|
if ($search_check and !$cgi->{keyword} and !_search_check($cols, $cgi)) {
|
||
|
|
return { error => GList::language('SYS_SEARCH_ERROR') };
|
||
|
|
}
|
||
|
|
|
||
|
|
# Require GT's modules
|
||
|
|
require GT::SQL::Condition;
|
||
|
|
require GT::Date;
|
||
|
|
|
||
|
|
my ($cd, @words);
|
||
|
|
my $query = '';
|
||
|
|
if ( $cgi->{keyword} and $cgi->{keyword} ne '*' ) { # keyword search
|
||
|
|
$cd = new GT::SQL::Condition('OR');
|
||
|
|
if ( $ma ) { # match any
|
||
|
|
@words = split(/\s/, $cgi->{keyword});
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
push @words, $cgi->{keyword};
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach my $c ( keys % $cols ) {
|
||
|
|
if ( $cols->{$c}->{weight} ) { # search weight
|
||
|
|
foreach my $w ( @words ) {
|
||
|
|
$cd->add($c, 'like', "%$w%");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$query = "keyword=$cgi->{keyword};";
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $bool = ( $ma ) ? 'OR' : 'AND';
|
||
|
|
$cd = new GT::SQL::Condition($bool);
|
||
|
|
if ($search_alpha) {
|
||
|
|
if ( $search_col and $search_alpha eq 'other') { # for Subscribers table only
|
||
|
|
my $tmp = GT::SQL::Condition->new('OR');
|
||
|
|
$tmp->add($search_col => '<' => '0');
|
||
|
|
$tmp->add(GT::SQL::Condition->new($search_col => '>=' => ':', $search_col => '<' => 'a'));
|
||
|
|
$tmp->add($search_col => '>=' => '[');
|
||
|
|
$cd->add($tmp);
|
||
|
|
$query .= 'alpha=other;';
|
||
|
|
}
|
||
|
|
elsif ( $search_col and $search_alpha eq 'number') { # for Subscribers table only
|
||
|
|
my $tmp = GT::SQL::Condition->new($search_col => '>=' => '0', $search_col => '<' => ':');
|
||
|
|
$cd->add($tmp);
|
||
|
|
$query .= 'alpha=number;';
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$cd->add($search_col, 'like', "$search_alpha%");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
foreach my $c ( keys % $cols ) {
|
||
|
|
my $tc = $c;
|
||
|
|
if ( $based_on ) {
|
||
|
|
$tc =~ s/$based_on\.//;
|
||
|
|
}
|
||
|
|
next if ( $c and $cgi->{$tc} and ( $c eq $user_field or $cgi->{$tc} eq '*' ));
|
||
|
|
if ( $cols->{$c}->{type} =~ /date|datetime|timestamp/mi or !$cgi->{$tc} ) { # DATE fields
|
||
|
|
if ( defined $cgi->{$tc} and $cgi->{$tc} eq '0' ) {
|
||
|
|
$cd->add($c, $cgi->{"$tc-opt"} || '=', $cgi->{$tc} );
|
||
|
|
$query .= "$tc=0;";
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $tmp = {'le' => '<=', 'ge' => '>=', 'lt' => '<', 'gt' => '>'};
|
||
|
|
my $format = $USER->{usr_date_format} || '%mm%-%dd%-%yyyy%';
|
||
|
|
foreach my $o (keys % {$tmp} ) {
|
||
|
|
next if ( !$cgi->{"$tc-$o"} );
|
||
|
|
my $v;
|
||
|
|
if ($int_field) {
|
||
|
|
$v = $cgi->{"$tc-$o"};
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$cgi->{"$tc-$o"} .= ( $o eq 'le' or $o eq 'lt' ) ? ' 23:59:58' : ' 00:00:01';
|
||
|
|
$v = GT::Date::timelocal(GT::Date::parse_format($cgi->{"$tc-$o"}, "$format %hh%:%MM%:%ss%"));
|
||
|
|
}
|
||
|
|
$cd->add($c, $tmp->{$o}, $v);
|
||
|
|
$query .= "$tc-$o=".$cgi->{"$tc-$o"}.';';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif ( $cgi->{"$tc-opt"} ) {
|
||
|
|
$cd->add($c, $cgi->{"$tc-opt"}, $cgi->{$tc});
|
||
|
|
$query .= "$tc=$cgi->{$tc};$c-opt=".$cgi->{"$tc-opt"}.";";
|
||
|
|
}
|
||
|
|
elsif ( $cols->{$c}->{type} =~ /char|varchar|text/mi ) { # TEXT fields
|
||
|
|
$cd->add($c, 'like', "%$cgi->{$tc}%");
|
||
|
|
$query .= "$tc=$cgi->{$tc};";
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$cd->add($c, '=', $cgi->{$tc});
|
||
|
|
$query .= "$tc=$cgi->{$tc};";
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
$query .= 'ma=1;' if ($ma);
|
||
|
|
my @extra = ('cs', 'mn_disable');
|
||
|
|
foreach (@extra) {
|
||
|
|
$query .= "$_=$cgi->{$_};" if ($cgi->{$_});
|
||
|
|
}
|
||
|
|
chop $query;
|
||
|
|
|
||
|
|
# System users will view their own record only
|
||
|
|
my $cond = new GT::SQL::Condition($cd);
|
||
|
|
if ( !$skip_user ) {
|
||
|
|
if ( $USER->{usr_type} != ADMINISTRATOR ) {
|
||
|
|
$cond->add($user_field, '=', $USER->{usr_username});
|
||
|
|
}
|
||
|
|
elsif ( $cgi->{$user_field} ) {
|
||
|
|
my $o = $cgi->{"$user_field-opt"} || '=';
|
||
|
|
$cond->add($user_field, $o, $cgi->{$user_field});
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $user = load_condition($show_user);
|
||
|
|
$cond->add($user_field, $user->{opt}, $user->{id});
|
||
|
|
}
|
||
|
|
}
|
||
|
|
# Do the search and count the results.
|
||
|
|
if ( !$select_all ) {
|
||
|
|
$db->select_options("ORDER BY $sb $so LIMIT $bg, $mh ");
|
||
|
|
}
|
||
|
|
my $sth = $db->select($cond) or die $GT::SQL::error;
|
||
|
|
my $hits= $db->hits;
|
||
|
|
|
||
|
|
return language($return_msg, 0) if ( $hits == 0 );
|
||
|
|
|
||
|
|
if ( $#words == -1 and $cgi->{lu} ) {
|
||
|
|
@words = split(/\s/, $cgi->{lu});
|
||
|
|
}
|
||
|
|
my @output;
|
||
|
|
my @colors = ('#ff8888', '#88ff88', '#8888ff', '#ffff88', '#ff88ff', '#88ffff', '#ffcccc', '#cccc99', '#ffffcc', '#ffccff');
|
||
|
|
while ( my $rs = $sth->fetchrow_hashref ) {
|
||
|
|
if ( $CFG->{highlight_color} ) {
|
||
|
|
if ( $#words != -1 ) {
|
||
|
|
foreach my $c ( keys % $cols ) {
|
||
|
|
next if ( !$cols->{$c}->{weight} );
|
||
|
|
my $j = 0;
|
||
|
|
foreach my $i (0..$#words) {
|
||
|
|
$j = 0 if ( $j > $#colors );
|
||
|
|
$rs->{$c} =~ s/$words[$i]/<span style="background-color: $colors[$j]">$words[$i]<\/span>/gi;
|
||
|
|
$j++;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
push @output, $rs;
|
||
|
|
}
|
||
|
|
|
||
|
|
return { hits => $hits,
|
||
|
|
results => \@output,
|
||
|
|
msg => language($return_msg, $hits),
|
||
|
|
query => $query,
|
||
|
|
mh => $mh,
|
||
|
|
nh => $nh,
|
||
|
|
lookup => $cgi->{keyword},
|
||
|
|
toolbar_table => $table_name
|
||
|
|
};
|
||
|
|
}
|
||
|
|
|
||
|
|
sub remove_attachments {
|
||
|
|
#-----------------------------------------------------------------------
|
||
|
|
#
|
||
|
|
my ($id, $dir) = @_;
|
||
|
|
|
||
|
|
my $path = "$CFG->{priv_path}/attachments/$dir/" . ($id % 10) . "/$id";
|
||
|
|
(-e $path) or return "<font color=red>Invalid path $path!</font>";
|
||
|
|
|
||
|
|
opendir (DIR, $path) or return GList::language('DIR_OPEN_ERR', $path, $!);
|
||
|
|
my @list = readdir(DIR);
|
||
|
|
closedir (DIR);
|
||
|
|
foreach my $file (@list) {
|
||
|
|
($file eq '.') and next;
|
||
|
|
($file eq '..') and next;
|
||
|
|
unlink "$path/$file";
|
||
|
|
}
|
||
|
|
rmdir $path;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub load_condition {
|
||
|
|
#-----------------------------------------------------------------------
|
||
|
|
# Loads the user listings in a group for searching
|
||
|
|
# It will be returned a hash
|
||
|
|
#
|
||
|
|
my $show_user = shift;
|
||
|
|
|
||
|
|
my $cgi = $IN->get_hash();
|
||
|
|
$show_user ||= $cgi->{users};
|
||
|
|
if ( $show_user and $USER->{usr_type} == ADMINISTRATOR) { # For admin
|
||
|
|
return { id => $USER->{usr_username}, opt => '<>' };
|
||
|
|
}
|
||
|
|
else { # Check current user
|
||
|
|
return { id => $USER->{usr_username}, opt => '=' };
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub get_data {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
# Get data of a record
|
||
|
|
#
|
||
|
|
my $table = shift;
|
||
|
|
|
||
|
|
my $values;
|
||
|
|
my $mod = $IN->param('modify');
|
||
|
|
|
||
|
|
if ( $IN->param('modify') == 0 ) {
|
||
|
|
$values = $IN->get_hash;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
my $lookup = {};
|
||
|
|
my $db = $DB->table($table);
|
||
|
|
my $pk = $db->pk;
|
||
|
|
foreach ( @$pk ) { $lookup->{$_} = $IN->param("$mod-$_"); }
|
||
|
|
$values = $db->get($lookup, 'HASH');
|
||
|
|
}
|
||
|
|
|
||
|
|
return $values;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub format_insert_cgi {
|
||
|
|
#-----------------------------------------------------------------------------
|
||
|
|
#
|
||
|
|
my ($db, $cgi) = @_;
|
||
|
|
|
||
|
|
$cgi ||= $IN->get_hash;
|
||
|
|
my $cols = $db->cols;
|
||
|
|
foreach ( keys % $cols ) {
|
||
|
|
if ( !exists $cgi->{$_} and uc($cols->{$_}->{form_type}) eq 'CHECKBOX' ) {
|
||
|
|
$cgi->{$_} = '';
|
||
|
|
}
|
||
|
|
next unless ( ref ($cgi->{$_}) eq 'ARRAY' );
|
||
|
|
$cgi->{$_} = join ($GT::SQL::Display::HTML::INPUT_SEPARATOR, sort (@{$cgi->{$_}}));
|
||
|
|
}
|
||
|
|
return $cgi;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub check_owner {
|
||
|
|
#--------------------------------------------------------------------
|
||
|
|
# User can only modify their own record, except admin
|
||
|
|
#
|
||
|
|
my ($table, $pre_fix, $id) = @_;
|
||
|
|
|
||
|
|
my $info = $DB->table($table)->get($id);
|
||
|
|
( $info ) or return "<font color=red>$id does not exist!</font>";
|
||
|
|
|
||
|
|
# Users can only modify their own records
|
||
|
|
if ( $USER->{usr_type} != ADMINISTRATOR and $info->{$pre_fix.'_user_id_fk'} ne $USER->{usr_username} ) {
|
||
|
|
return GList::language('SYS_PER_DENIED');
|
||
|
|
}
|
||
|
|
|
||
|
|
return $info;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub check_limit {
|
||
|
|
#------------------------------------------------------------------------------
|
||
|
|
# Check account limits
|
||
|
|
#
|
||
|
|
my ($type, $list_id) = @_;
|
||
|
|
return if ($USER->{usr_type} != LIMITED_USER);
|
||
|
|
|
||
|
|
$error = '';
|
||
|
|
if ($type eq 'list') { # limit number of list
|
||
|
|
if ($DB->table('Lists')->count({ lst_user_id_fk => $USER->{usr_username} }) >= $USER->{usr_limit_list}) {
|
||
|
|
$error = GList::language('SYS_OVERLIMIT_LIST');
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif ($type eq 'sublist') { # limit number of subscribers per list
|
||
|
|
if ($DB->table('Subscribers')->count(
|
||
|
|
{ sub_user_id_fk => $USER->{usr_username}, sub_list_id_fk => $list_id }) >= $USER->{usr_limit_sublist} ) {
|
||
|
|
$error = GList::language('SYS_OVERLIMIT_SUBLIST');
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
elsif ($type eq 'email30') { # limit number of email sending out in the last 30 days
|
||
|
|
require GT::Date;
|
||
|
|
require GT::SQL::Condition;
|
||
|
|
my $last30 = GT::Date::date_sub(GT::Date::date_get(), 30);
|
||
|
|
my $unix_time = date_to_time($last30);
|
||
|
|
my $num_sent = $DB->table('MailingIndex', 'EmailMailings')->count(
|
||
|
|
GT::SQL::Condition->new(
|
||
|
|
mli_user_id_fk => '=' => $USER->{usr_username},
|
||
|
|
eml_sent => '>=' => $unix_time
|
||
|
|
)
|
||
|
|
);
|
||
|
|
if ( $num_sent >= $USER->{usr_limit_email30} ) {
|
||
|
|
$error = GList::language('SYS_OVERLIMIT_EMAIL30');
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
return $num_sent;
|
||
|
|
}
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub load_language {
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Loads the language.txt file. You can either pass in a template set, or let
|
||
|
|
# it auto-detect from t=, or fall back to the default.
|
||
|
|
#
|
||
|
|
my $t = shift || scalar $IN->param('t') || $CFG->{template_set} || 'gossamer';
|
||
|
|
$LANGUAGE = undef if !$LANG_TPL or $LANG_TPL ne $t;
|
||
|
|
$LANGUAGE ||= GT::Config->load("$CFG->{priv_path}/templates/$t/language.txt", { create_ok => 1, inheritance => 1, local => 1, header => <<HEADER });
|
||
|
|
# This file is auto generated and contains a perl hash of
|
||
|
|
# your language variables for the '$t' template set.
|
||
|
|
# Generated on: [localtime]
|
||
|
|
|
||
|
|
HEADER
|
||
|
|
$LANG_TPL = $t;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub load_globals {
|
||
|
|
# -----------------------------------------------------------------------------
|
||
|
|
# Loads the globals.txt file into $GLOBALS. Takes one (optional) value; if
|
||
|
|
# false or absent, compile_subs will be passed to the GT::Config object, if
|
||
|
|
# true it will be omitted.
|
||
|
|
#
|
||
|
|
my $no_subs = shift;
|
||
|
|
$GLOBALS = undef if $no_subs xor $GLOB_NO_SUBS;
|
||
|
|
$GLOBALS ||= GT::Config->load("$CFG->{priv_path}/templates/common/globals.txt", {
|
||
|
|
$no_subs ? () : (compile_subs => 'GList'),
|
||
|
|
inheritance => 1,
|
||
|
|
local => 1,
|
||
|
|
cache => 1,
|
||
|
|
header => <<'HEADER'
|
||
|
|
# This file is auto generated and contains a perl hash of
|
||
|
|
# your template globals.
|
||
|
|
# Generated on: [localtime]
|
||
|
|
|
||
|
|
HEADER
|
||
|
|
});
|
||
|
|
$GLOB_NO_SUBS = $no_subs;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub language {
|
||
|
|
# ------------------------------------------------------------------
|
||
|
|
# Process a language request, it's only loaded once, and saved in
|
||
|
|
# $LANGUAGE.
|
||
|
|
#
|
||
|
|
require GT::Config;
|
||
|
|
my $code = shift || '';
|
||
|
|
|
||
|
|
load_language();
|
||
|
|
|
||
|
|
if (exists $LANGUAGE->{$code}) {
|
||
|
|
return @_ ? sprintf($LANGUAGE->{$code}, @_) : $LANGUAGE->{$code};
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return $code;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub fatal {
|
||
|
|
# --------------------------------------------------------------
|
||
|
|
# Return a fatal error message to the browser.
|
||
|
|
#
|
||
|
|
die @_ if (GT::Base->in_eval()); # Don't do anything if we are in eval.
|
||
|
|
|
||
|
|
my $msg = shift;
|
||
|
|
my $debug = defined $CFG->{debug_level} ? $CFG->{debug_level} : $DEBUG;
|
||
|
|
|
||
|
|
$IN ||= new GT::CGI;
|
||
|
|
if (defined $CFG and exists $CFG->{error_message} and $CFG->{error_message}) {
|
||
|
|
$CFG->{error_message} =~ s,<%error%>,$msg,g;
|
||
|
|
$CFG->{error_message} =~ s,<%environment%>,environment(),eg;
|
||
|
|
display('error_form.html', { msg => language('SYS_FATAL', $CFG->{error_message}) });
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
display('error_form.html', { msg => language('SYS_FATAL', $msg) });
|
||
|
|
}
|
||
|
|
if ($debug) {
|
||
|
|
print environment();
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub view_file {
|
||
|
|
#---------------------------------------------------------------
|
||
|
|
# View a file
|
||
|
|
#
|
||
|
|
my $fn = $IN->param('fn');
|
||
|
|
my $fd = $IN->param('fd');
|
||
|
|
my $type = $IN->param('ft');
|
||
|
|
$fn and $fd or return display('error_form.html', { msg => language('SYS_FILE_INVALID') });
|
||
|
|
|
||
|
|
# Check file existing
|
||
|
|
my $file = $DB->table($type ? 'MessageAttachments' : 'MailingAttachments')->get($fn);
|
||
|
|
$file or return display('error_form.html', { msg => language('SYS_FILE_NOT_FOUND', $fn) });
|
||
|
|
|
||
|
|
my $full_file = "$CFG->{priv_path}/attachments/".(( $type ) ? 'messages' : 'mailings')."/".($fd % 10)."/$fd/$fn";
|
||
|
|
my $file_name = ( $type ) ? 'att_file_name' : 'mat_file_name';
|
||
|
|
my $content_type = _load_mime($file->{$file_name});
|
||
|
|
my ($ext) = $full_file =~ /\.([^.]+)$/;
|
||
|
|
my $file_size = -s $full_file;
|
||
|
|
if (open DATA, $full_file) {
|
||
|
|
if (($content_type =~ m/text/ or -T $full_file) and uc($ext) ne 'PDF') {
|
||
|
|
print $IN->header;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
warn "Content-type: $content_type, Content-Length: $file_size";
|
||
|
|
print $IN->header({
|
||
|
|
'-type' => $content_type,
|
||
|
|
'-Content-Length' => $file_size,
|
||
|
|
});
|
||
|
|
}
|
||
|
|
binmode STDOUT;
|
||
|
|
binmode DATA;
|
||
|
|
my $buffer;
|
||
|
|
print $buffer while (read(DATA, $buffer, READ_SIZE));
|
||
|
|
close DATA;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return ('error_form.html', { msg => language('SYS_FILE_ERR', $fn) });
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub download_file {
|
||
|
|
#--------------------------------------------------------------
|
||
|
|
# Download a file
|
||
|
|
#
|
||
|
|
my $fn = $IN->param('fn');
|
||
|
|
my $fd = $IN->param('fd');
|
||
|
|
my $type = $IN->param('ft');
|
||
|
|
( $fn and $fd ) or return display('error_form.html', { msg => language('SYS_FILE_INVALID') });
|
||
|
|
|
||
|
|
# Check file existing
|
||
|
|
my $file = $DB->table(( $type ) ? 'MessageAttachments' : 'MailingAttachments')->get($fn);
|
||
|
|
$file or return display('error_form.html', { msg => language('SYS_FILE_NOT_FOUND', $fn) });
|
||
|
|
|
||
|
|
my $full_file = "$CFG->{priv_path}/attachments/".($type ? 'messages' : 'mailings')."/".($fd % 10)."/$fd/$fn";
|
||
|
|
my $file_name = $type ? 'att_File_Name' : 'mat_File_Name';
|
||
|
|
my $file_size = -s $full_file;
|
||
|
|
if (open DATA, $full_file) {
|
||
|
|
print $IN->header(
|
||
|
|
'-type' => 'application/download',
|
||
|
|
'-Content-Length' => $file_size,
|
||
|
|
'-Content-Transfer-Encoding' => 'binary',
|
||
|
|
'-Content-Disposition' => \"attachment; filename=$file->{$file_name}"
|
||
|
|
);
|
||
|
|
binmode STDOUT;
|
||
|
|
binmode DATA;
|
||
|
|
my $buffer;
|
||
|
|
print $buffer while (read(DATA, $buffer, READ_SIZE));
|
||
|
|
close DATA;
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return ('error_form.html', { msg => language('SYS_FILE_ERR', $fn) } );
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
sub encrypt {
|
||
|
|
# -------------------------------------------------------------------
|
||
|
|
my ($clear_pass, $salt) = @_;
|
||
|
|
defined $salt or ($salt = '');
|
||
|
|
require GT::MD5::Crypt;
|
||
|
|
if (! $salt) {
|
||
|
|
my @rand_salt = ('a' .. 'z', 'A' .. 'Z', 0 .. 9, '.', '/');
|
||
|
|
for (1 .. 8) { $salt .= $rand_salt[rand @rand_salt]; }
|
||
|
|
}
|
||
|
|
my $enc_pass = GT::MD5::Crypt::gt_md5_crypt($clear_pass, $salt);
|
||
|
|
return $enc_pass;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub date_to_time {
|
||
|
|
my ($date, $date_format) = @_;
|
||
|
|
my $lt;
|
||
|
|
my @localtime;
|
||
|
|
require GT::Date;
|
||
|
|
|
||
|
|
$date_format ||= '%yyyy%-%mm%-%dd%';
|
||
|
|
DATE: {
|
||
|
|
# First, try the admin format:
|
||
|
|
ref($lt = GT::Date::_parse_format($date, $date_format)) eq 'ARRAY' and (@localtime = @$lt), last DATE;
|
||
|
|
# Okay, it wasn't simply them modifying what was displayed, so let's try some other common formats:
|
||
|
|
# just the date, no time:
|
||
|
|
# yyyy/mm/dd
|
||
|
|
$date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2}$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d%")}), last DATE;
|
||
|
|
# 12 hour time:
|
||
|
|
# yyyy/mm/dd hh:MM [AP]M
|
||
|
|
$date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2} [AaPp][Mm]$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %h%:%M% %tt%")}), last DATE;
|
||
|
|
# yyyy/mm/dd hh:MM:ss [AP]M
|
||
|
|
$date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}:\d{1,2} [AaPp][Mm]$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %h%:%M%:%s% %tt%")}), last DATE;
|
||
|
|
# 24 hour time:
|
||
|
|
# yyyy/mm/dd HH:MM
|
||
|
|
$date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %H%:%M%")}), last DATE;
|
||
|
|
# yyyy/mm/dd HH:MM:ss
|
||
|
|
$date =~ m|^\d{4}([-/])\d{1,2}([-/])\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}$| and (@localtime = @{GT::Date::_parse_format($date, "%yyyy%$1%m%$2%d% %H%:%M%:%s%")}), last DATE;
|
||
|
|
# Common formats that can't be recognized:
|
||
|
|
# dd/mm/yyyy - These two are conflicting US/European formats and it would
|
||
|
|
# mm/dd/yyyy - be impossible to figure out which one you are trying to use.
|
||
|
|
}
|
||
|
|
|
||
|
|
return scalar @localtime ? GT::Date::timelocal(@localtime) : undef;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub paging {
|
||
|
|
# --------------------------------------------------------------
|
||
|
|
# Returns paging variables for the templates.
|
||
|
|
# Takes 4 arguments: number of hits, hits per page, the current page, and the number of pages to show.
|
||
|
|
# Takes 1 additional optional argument - true or false, indicating whether or not a ... system will be
|
||
|
|
# used. If set, one extra number will be returned if there is just one extra number needed, and a
|
||
|
|
# 'dotdotdot' variable will be available as 1 if ... is needed.
|
||
|
|
# Example: when displaying paging of 9 with 11 pages, you would get:
|
||
|
|
# 1 2 3 4 5 6 7 8 9 and you would have the "dotdotdot" variable set, so you would put a ... and then 11.
|
||
|
|
# Now, if you were displaying paging of 9 with 10 pages, you would actually get _10_ numbers:
|
||
|
|
# 1 2 3 4 5 6 7 8 9 10 and the "dotdotdot" wouldn't be set, so you wouldn't put the ... 10, since
|
||
|
|
# 1 2 3 4 5 6 7 8 9 ... 10 would look silly.
|
||
|
|
# Returned is a hashref: { paging => LOOP, top_page => INTEGER }, and possibly dotdotdot => 1
|
||
|
|
# Inside the loop you have: <%page_num%> and <%is_current_page%>.
|
||
|
|
#
|
||
|
|
my ($num_hits, $max_hits, $current_page, $disp_pages, $want_dotdotdot) = @_;
|
||
|
|
|
||
|
|
$disp_pages ||= 20;
|
||
|
|
$max_hits ||= 25;
|
||
|
|
my $num_pages = int($num_hits / $max_hits);
|
||
|
|
$num_pages++ if $num_hits % $max_hits;
|
||
|
|
my ($start, $end);
|
||
|
|
if ($num_pages <= $disp_pages) {
|
||
|
|
$start = 1;
|
||
|
|
$end = $num_pages;
|
||
|
|
}
|
||
|
|
elsif ($current_page >= $num_pages - $disp_pages / 2) {
|
||
|
|
$end = $num_pages;
|
||
|
|
$start = $end - $disp_pages + 1;
|
||
|
|
}
|
||
|
|
elsif ($current_page <= $disp_pages / 2) {
|
||
|
|
$start = 1;
|
||
|
|
$end = $disp_pages;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$start = $current_page - int($disp_pages / 2) + 1;
|
||
|
|
$start-- if $disp_pages % 2;
|
||
|
|
$end = $current_page + int($disp_pages / 2);
|
||
|
|
}
|
||
|
|
my $need_dotdotdot;
|
||
|
|
if ($want_dotdotdot) {
|
||
|
|
if ($num_pages == $end + 1) {
|
||
|
|
++$end;
|
||
|
|
}
|
||
|
|
elsif ($num_pages > $end) {
|
||
|
|
$need_dotdotdot = 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
my @pages = map +{ page_num => $_, (($_ == $current_page) ? (is_current_page => 1) : ()) }, $start .. $end;
|
||
|
|
return {
|
||
|
|
paging => \@pages,
|
||
|
|
top_page => $num_pages,
|
||
|
|
($want_dotdotdot && $need_dotdotdot ? (dotdotdot => 1) : ())
|
||
|
|
};
|
||
|
|
}
|
||
|
|
sub wild_cards() {
|
||
|
|
require GT::SQL::Condition;
|
||
|
|
return $DB->table('StopLists')->select(GT::SQL::Condition->new(stl_email => LIKE => "%*%", stl_email => LIKE => "%?%", "OR"), ['stl_email'])->fetchall_arrayref;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _redirect_login_url {
|
||
|
|
# --------------------------------------------------------------
|
||
|
|
# Redirect the user to the login screen.
|
||
|
|
#
|
||
|
|
my $url = $IN->url( query_string => 1 );
|
||
|
|
$url = $CFG->{cgi_url} . "/user.cgi?url=" . $IN->escape($url);
|
||
|
|
foreach my $preserve (@{$CFG->{dynamic_preserve}}) {
|
||
|
|
my $val = $IN->param($preserve);
|
||
|
|
defined $val or next;
|
||
|
|
$url .= ";$preserve=" . $IN->escape($val);
|
||
|
|
}
|
||
|
|
return $url;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _load_mime {
|
||
|
|
# --------------------------------------------------------------------
|
||
|
|
# Load the config file into a hash.
|
||
|
|
#
|
||
|
|
my ($file, $name) = @_;
|
||
|
|
$name ||= $file;
|
||
|
|
require GT::MIMETypes;
|
||
|
|
my $guess = GT::MIMETypes->guess_type($name);
|
||
|
|
if (!$guess or $guess eq 'application/octet-stream') {
|
||
|
|
if (-e $file) {
|
||
|
|
$guess = -T _ ? 'text/plain' : 'application/octet-stream';
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
$guess = 'application/octet-stream';
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return $guess;
|
||
|
|
}
|
||
|
|
|
||
|
|
sub _load_global {
|
||
|
|
my $name = shift;
|
||
|
|
load_globals();
|
||
|
|
return if (!exists $GLOBALS->{$name});
|
||
|
|
|
||
|
|
my $value = $GLOBALS->{$name};
|
||
|
|
$value = $value->() if ref $value eq 'CODE';
|
||
|
|
return $value;
|
||
|
|
}
|
||
|
|
|
||
|
|
1;
|