First pass at adding key files
This commit is contained in:
dsainty
commit
aa25e9347f
1
README.md
Normal file
1
README.md
Normal file
@ -0,0 +1 @@
|
||||
All the legacy code 'n' stuff from the "home" directory of the legacy server, for all things Gossamer Forums related.
|
||||
1
forum.slowtwitch.com/cgi-bin
Symbolic link
1
forum.slowtwitch.com/cgi-bin
Symbolic link
@ -0,0 +1 @@
|
||||
/var/home/slowtwitch/site/forum.slowtwitch.com/cgi-bin
|
||||
336
forum.slowtwitch.com/modperl.conf
Normal file
336
forum.slowtwitch.com/modperl.conf
Normal file
@ -0,0 +1,336 @@
|
||||
#
|
||||
# mod_perl configuration file
|
||||
#
|
||||
|
||||
# The following options should not be changed:
|
||||
ServerType standalone
|
||||
ServerRoot "/var/home/slowtwitch/forum.slowtwitch.com"
|
||||
PidFile /var/home/slowtwitch/forum.slowtwitch.com/logs/modperl.pid
|
||||
ScoreBoardFile /var/home/slowtwitch/forum.slowtwitch.com/logs/modperl.scoreboard
|
||||
DocumentRoot /var/home/slowtwitch/forum.slowtwitch.com/www
|
||||
ResourceConfig /dev/null
|
||||
AccessConfig /dev/null
|
||||
Timeout 1200
|
||||
|
||||
# Set the user/group apache is going to run as.
|
||||
User slowtwitch
|
||||
Group slowtwitch
|
||||
|
||||
# Set proc limits
|
||||
RLimitCPU 600
|
||||
RLimitMEM 157286400
|
||||
|
||||
|
||||
# KeepAlive should _not_ be on since this is running behind
|
||||
# a proxy.
|
||||
KeepAlive Off
|
||||
|
||||
# You must leave the port alone in order for /perl/ to
|
||||
# be proxied properly.
|
||||
Port 8001
|
||||
|
||||
# Please do not adjust these settings, this server is running
|
||||
# behind a proxy, and does not need a large number of clients
|
||||
# active.
|
||||
MinSpareServers 5
|
||||
MaxSpareServers 15
|
||||
StartServers 10
|
||||
MaxClients 75
|
||||
MaxRequestsPerChild 1000
|
||||
|
||||
# Below is a list of modules that will be loaded. If you add
|
||||
# or remove any modules, you must edit the AddModule section
|
||||
# below.
|
||||
|
||||
#LoadModule mmap_static_module /usr/lib/httpd/mod_mmap_static.so
|
||||
#LoadModule vhost_alias_module /usr/lib/httpd/mod_vhost_alias.so
|
||||
LoadModule env_module /usr/lib/httpd/mod_env.so
|
||||
LoadModule define_module /usr/lib/httpd/mod_define.so
|
||||
LoadModule config_log_module /usr/lib/httpd/mod_log_config.so
|
||||
#LoadModule agent_log_module /usr/lib/httpd/mod_log_agent.so
|
||||
#LoadModule referer_log_module /usr/lib/httpd/mod_log_referer.so
|
||||
#LoadModule mime_magic_module /usr/lib/httpd/mod_mime_magic.so
|
||||
LoadModule mime_module /usr/lib/httpd/mod_mime.so
|
||||
LoadModule negotiation_module /usr/lib/httpd/mod_negotiation.so
|
||||
LoadModule status_module /usr/lib/httpd/mod_status.so
|
||||
LoadModule info_module /usr/lib/httpd/mod_info.so
|
||||
LoadModule includes_module /usr/lib/httpd/mod_include.so
|
||||
LoadModule autoindex_module /usr/lib/httpd/mod_autoindex.so
|
||||
LoadModule dir_module /usr/lib/httpd/mod_dir.so
|
||||
LoadModule cgi_module /usr/lib/httpd/mod_cgi.so
|
||||
#LoadModule asis_module /usr/lib/httpd/mod_asis.so
|
||||
LoadModule imap_module /usr/lib/httpd/mod_imap.so
|
||||
LoadModule action_module /usr/lib/httpd/mod_actions.so
|
||||
#LoadModule speling_module /usr/lib/httpd/mod_speling.so
|
||||
LoadModule userdir_module /usr/lib/httpd/mod_userdir.so
|
||||
LoadModule alias_module /usr/lib/httpd/mod_alias.so
|
||||
LoadModule rewrite_module /usr/lib/httpd/mod_rewrite.so
|
||||
LoadModule access_module /usr/lib/httpd/mod_access.so
|
||||
LoadModule auth_module /usr/lib/httpd/mod_auth.so
|
||||
#LoadModule anon_auth_module /usr/lib/httpd/mod_auth_anon.so
|
||||
#LoadModule dbm_auth_module /usr/lib/httpd/mod_auth_dbm.so
|
||||
#LoadModule db_auth_module /usr/lib/httpd/mod_auth_db.so
|
||||
#LoadModule digest_module /usr/lib/httpd/mod_digest.so
|
||||
#LoadModule proxy_module /usr/lib/httpd/libproxy.so
|
||||
#LoadModule cern_meta_module /usr/lib/httpd/mod_cern_meta.so
|
||||
#LoadModule expires_module /usr/lib/httpd/mod_expires.so
|
||||
#LoadModule headers_module /usr/lib/httpd/mod_headers.so
|
||||
LoadModule usertrack_module /usr/lib/httpd/mod_usertrack.so
|
||||
#LoadModule example_module /usr/lib/httpd/mod_example.so
|
||||
#LoadModule unique_id_module /usr/lib/httpd/mod_unique_id.so
|
||||
LoadModule setenvif_module /usr/lib/httpd/mod_setenvif.so
|
||||
#LoadModule ssl_module /usr/lib/httpd/libssl.so
|
||||
LoadModule perl_module /usr/lib/httpd/libperl.so
|
||||
#LoadModule php4_module /usr/lib/httpd/libphp4.so
|
||||
#LoadModule gzip_module /usr/lib/httpd/mod_gzip.so
|
||||
#LoadModule throttle_module /usr/lib/httpd/mod_throttle.so
|
||||
LoadModule backhand_module /usr/lib/httpd/mod_backhand.so
|
||||
|
||||
# This list below must correspond with the list of modules you have
|
||||
# enabled above.
|
||||
|
||||
ClearModuleList
|
||||
#AddModule mod_mmap_static.c
|
||||
#AddModule mod_vhost_alias.c
|
||||
AddModule mod_env.c
|
||||
AddModule mod_define.c
|
||||
AddModule mod_log_config.c
|
||||
#AddModule mod_log_agent.c
|
||||
#AddModule mod_log_referer.c
|
||||
#AddModule mod_mime_magic.c
|
||||
AddModule mod_mime.c
|
||||
AddModule mod_negotiation.c
|
||||
AddModule mod_status.c
|
||||
AddModule mod_info.c
|
||||
AddModule mod_include.c
|
||||
AddModule mod_autoindex.c
|
||||
AddModule mod_dir.c
|
||||
AddModule mod_cgi.c
|
||||
#AddModule mod_asis.c
|
||||
AddModule mod_imap.c
|
||||
AddModule mod_actions.c
|
||||
#AddModule mod_speling.c
|
||||
AddModule mod_userdir.c
|
||||
AddModule mod_alias.c
|
||||
AddModule mod_rewrite.c
|
||||
AddModule mod_access.c
|
||||
AddModule mod_auth.c
|
||||
#AddModule mod_auth_anon.c
|
||||
#AddModule mod_auth_dbm.c
|
||||
#AddModule mod_auth_db.c
|
||||
#AddModule mod_digest.c
|
||||
#AddModule mod_proxy.c
|
||||
#AddModule mod_cern_meta.c
|
||||
#AddModule mod_expires.c
|
||||
#AddModule mod_headers.c
|
||||
AddModule mod_usertrack.c
|
||||
#AddModule mod_example.c
|
||||
#AddModule mod_unique_id.c
|
||||
AddModule mod_so.c
|
||||
AddModule mod_setenvif.c
|
||||
#AddModule mod_ssl.c
|
||||
AddModule mod_perl.c
|
||||
#AddModule mod_php4.c
|
||||
#AddModule mod_gzip.c
|
||||
#AddModule mod_throttle.c
|
||||
AddModule mod_backhand.c
|
||||
|
||||
# Section 2: Main Server Configuration
|
||||
ServerAdmin webmaster@forum.slowtwitch.com
|
||||
#Include /etc/httpd/forum_servername.conf
|
||||
UseCanonicalName Off
|
||||
|
||||
DirectoryIndex index.html index.htm default.htm index.shtm index.shtml index.cgi index.php
|
||||
AccessFileName .htaccess
|
||||
TypesConfig /var/home/slowtwitch/forum.slowtwitch.com/modperl.mime_types
|
||||
DefaultType text/plain
|
||||
ExtendedStatus On
|
||||
ServerSignature Off
|
||||
ServerTokens ProductOnly
|
||||
|
||||
# Do not enable hostname lookups, ip's will be looked up nightly
|
||||
# and will be replaced with the hostname in the log files.
|
||||
HostnameLookups Off
|
||||
|
||||
# Logging Directives
|
||||
LogLevel warn
|
||||
LogFormat "%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-Agent}i\"" combined
|
||||
LogFormat "%h %l %u %t \"%r\" %>s %b" common
|
||||
LogFormat "%{Referer}i -> %U" referer
|
||||
LogFormat "%{User-agent}i" agent
|
||||
CustomLog /var/home/slowtwitch/forum.slowtwitch.com/logs/perl_access_log combined
|
||||
ErrorLog /var/home/slowtwitch/forum.slowtwitch.com/logs/perl_error_log
|
||||
|
||||
# Default Handlers
|
||||
AddType text/html .shtm .shtml
|
||||
AddHandler cgi-script .cgi
|
||||
AddHandler server-parsed .htm .html .shtm .shtml
|
||||
AddHandler send-as-is asis
|
||||
AddHandler imap-file map
|
||||
|
||||
# Root Filesystem
|
||||
<Directory />
|
||||
Options FollowSymLinks
|
||||
AllowOverride None
|
||||
</Directory>
|
||||
|
||||
# Document Root
|
||||
<Directory /var/home/slowtwitch/forum.slowtwitch.com/>
|
||||
Options All -Indexes
|
||||
AllowOverride All
|
||||
</Directory>
|
||||
|
||||
# Disallow any attempts at viewing .ht* files
|
||||
<Files ~ "^\.ht">
|
||||
Order allow,deny
|
||||
Deny from all
|
||||
Satisfy All
|
||||
</Files>
|
||||
|
||||
# Setup /icons/ alias
|
||||
Alias /icons/ /var/httpd/icons/
|
||||
<Location /icons/>
|
||||
Options MultiViews
|
||||
AllowOverride None
|
||||
Order allow,deny
|
||||
Allow from all
|
||||
</Location>
|
||||
|
||||
# View server status information
|
||||
<Location /server-status>
|
||||
# Protect this information from prying eyes
|
||||
AuthType Basic
|
||||
AuthName Protected
|
||||
AuthUserFile /home/slowtwitch/.gpanel/status_htpasswd
|
||||
require valid-user
|
||||
|
||||
SetHandler server-status
|
||||
Order deny,allow
|
||||
Deny from all
|
||||
Allow from localhost
|
||||
</Location>
|
||||
|
||||
# View perl info
|
||||
<Location /perl-status>
|
||||
# Protect this information from prying eyes
|
||||
AuthType Basic
|
||||
AuthName Protected
|
||||
AuthUserFile /home/slowtwitch/.gpanel/status_htpasswd
|
||||
require valid-user
|
||||
|
||||
SetHandler perl-script
|
||||
PerlHandler Apache::Status
|
||||
Order deny,allow
|
||||
Deny from all
|
||||
Allow from localhost
|
||||
</Location>
|
||||
|
||||
# Directory Indexing and Content Negotiation Options
|
||||
IndexOptions FancyIndexing
|
||||
AddIconByEncoding (CMP,/icons/compressed.gif) x-compress x-gzip
|
||||
AddIconByType (TXT,/icons/text.gif) text/*
|
||||
AddIconByType (IMG,/icons/image2.gif) image/*
|
||||
AddIconByType (SND,/icons/sound2.gif) audio/*
|
||||
AddIconByType (VID,/icons/movie.gif) video/*
|
||||
AddIcon /icons/binary.gif .bin .exe
|
||||
AddIcon /icons/binhex.gif .hqx
|
||||
AddIcon /icons/tar.gif .tar
|
||||
AddIcon /icons/world2.gif .wrl .wrl.gz .vrml .vrm .iv
|
||||
AddIcon /icons/compressed.gif .Z .z .tgz .gz .zip
|
||||
AddIcon /icons/a.gif .ps .ai .eps
|
||||
AddIcon /icons/layout.gif .html .shtml .htm .pdf
|
||||
AddIcon /icons/text.gif .txt
|
||||
AddIcon /icons/c.gif .c
|
||||
AddIcon /icons/p.gif .pl .py
|
||||
AddIcon /icons/f.gif .for
|
||||
AddIcon /icons/dvi.gif .dvi
|
||||
AddIcon /icons/uuencoded.gif .uu
|
||||
AddIcon /icons/script.gif .conf .sh .shar .csh .ksh .tcl
|
||||
AddIcon /icons/tex.gif .tex
|
||||
AddIcon /icons/bomb.gif core
|
||||
AddIcon /icons/back.gif ..
|
||||
AddIcon /icons/hand.right.gif README
|
||||
AddIcon /icons/folder.gif ^^DIRECTORY^^
|
||||
AddIcon /icons/blank.gif ^^BLANKICON^^
|
||||
DefaultIcon /icons/unknown.gif
|
||||
ReadmeName README
|
||||
HeaderName HEADER
|
||||
IndexIgnore .??* *~ *# HEADER* README* RCS CVS *,v *,t
|
||||
AddEncoding x-compress Z
|
||||
AddEncoding x-gzip gz tgz
|
||||
AddLanguage da .dk
|
||||
AddLanguage nl .nl
|
||||
AddLanguage en .en
|
||||
AddLanguage et .ee
|
||||
AddLanguage fr .fr
|
||||
AddLanguage de .de
|
||||
AddLanguage el .el
|
||||
AddLanguage he .he
|
||||
AddCharset ISO-8859-8 .iso8859-8
|
||||
AddLanguage it .it
|
||||
AddLanguage ja .ja
|
||||
AddCharset ISO-2022-JP .jis
|
||||
AddLanguage kr .kr
|
||||
AddCharset ISO-2022-KR .iso-kr
|
||||
AddLanguage nn .nn
|
||||
AddLanguage no .no
|
||||
AddLanguage pl .po
|
||||
AddCharset ISO-8859-2 .iso-pl
|
||||
AddLanguage pt .pt
|
||||
AddLanguage pt-br .pt-br
|
||||
AddLanguage ltz .lu
|
||||
AddLanguage ca .ca
|
||||
AddLanguage es .es
|
||||
AddLanguage sv .sv
|
||||
AddLanguage cz .cz
|
||||
AddLanguage ru .ru
|
||||
AddLanguage zh-tw .tw
|
||||
AddLanguage tw .tw
|
||||
AddCharset Big5 .Big5 .big5
|
||||
AddCharset WINDOWS-1251 .cp-1251
|
||||
AddCharset CP866 .cp866
|
||||
AddCharset ISO-8859-5 .iso-ru
|
||||
AddCharset KOI8-R .koi8-r
|
||||
AddCharset UCS-2 .ucs2
|
||||
AddCharset UCS-4 .ucs4
|
||||
AddCharset UTF-8 .utf8
|
||||
LanguagePriority en da nl et fr de el it ja kr no pl pt pt-br ru ltz ca es sv tw
|
||||
AddType application/x-tar .tgz
|
||||
|
||||
Include /etc/httpd/forum_backhand.conf
|
||||
|
||||
# Load the mod_perl startup file, and setup the mod_perl handler so that
|
||||
# the ip address is updated for all requests.
|
||||
PerlRequire /var/home/slowtwitch/forum.slowtwitch.com/modperl_startup.pl
|
||||
PerlPostReadRequestHandler My::ProxyRemoteAddr
|
||||
|
||||
# By default only scripts in /perl/ are executed under mod_perl.
|
||||
Alias /perl/ /var/home/slowtwitch/forum.slowtwitch.com/perl/
|
||||
<Directory /var/home/slowtwitch/forum.slowtwitch.com/perl/>
|
||||
Order Allow,Deny
|
||||
Allow From All
|
||||
AllowOverride All
|
||||
Options +ExecCGI
|
||||
|
||||
SetHandler perl-script
|
||||
PerlHandler Apache::Registry
|
||||
PerlSendHeader On
|
||||
</Directory>
|
||||
|
||||
# If you want your /cgi-bin/ to be run under mod_perl, uncomment
|
||||
# the following:
|
||||
Alias /cgi-bin/ /var/home/slowtwitch/forum.slowtwitch.com/cgi-bin/
|
||||
<Directory /var/home/slowtwitch/forum.slowtwitch.com/cgi-bin/>
|
||||
Order Allow,Deny
|
||||
Allow From All
|
||||
AllowOverride All
|
||||
Options +ExecCGI
|
||||
|
||||
SetHandler perl-script
|
||||
PerlHandler Apache::Registry
|
||||
PerlSendHeader On
|
||||
</Directory>
|
||||
|
||||
# vim:syn=apache:sw=4:et
|
||||
|
||||
|
||||
336
forum.slowtwitch.com/modperl.conf.bak
Normal file
336
forum.slowtwitch.com/modperl.conf.bak
Normal file
@ -0,0 +1,336 @@
|
||||
#
|
||||
# mod_perl configuration file
|
||||
#
|
||||
|
||||
# The following options should not be changed:
|
||||
ServerType standalone
|
||||
ServerRoot "/var/home/slowtwitch/forum.slowtwitch.com"
|
||||
PidFile /var/home/slowtwitch/forum.slowtwitch.com/logs/modperl.pid
|
||||
ScoreBoardFile /var/home/slowtwitch/forum.slowtwitch.com/logs/modperl.scoreboard
|
||||
DocumentRoot /var/home/slowtwitch/forum.slowtwitch.com/www
|
||||
ResourceConfig /dev/null
|
||||
AccessConfig /dev/null
|
||||
Timeout 1200
|
||||
|
||||
# Set the user/group apache is going to run as.
|
||||
User slowtwitch
|
||||
Group slowtwitch
|
||||
|
||||
# Set proc limits
|
||||
RLimitCPU 600
|
||||
RLimitMEM 157286400
|
||||
|
||||
|
||||
# KeepAlive should _not_ be on since this is running behind
|
||||
# a proxy.
|
||||
KeepAlive Off
|
||||
|
||||
# You must leave the port alone in order for /perl/ to
|
||||
# be proxied properly.
|
||||
Port 8003
|
||||
|
||||
# Please do not adjust these settings, this server is running
|
||||
# behind a proxy, and does not need a large number of clients
|
||||
# active.
|
||||
MinSpareServers 5
|
||||
MaxSpareServers 15
|
||||
StartServers 10
|
||||
MaxClients 50
|
||||
MaxRequestsPerChild 1000
|
||||
|
||||
# Below is a list of modules that will be loaded. If you add
|
||||
# or remove any modules, you must edit the AddModule section
|
||||
# below.
|
||||
|
||||
#LoadModule mmap_static_module /usr/lib/httpd/mod_mmap_static.so
|
||||
#LoadModule vhost_alias_module /usr/lib/httpd/mod_vhost_alias.so
|
||||
LoadModule env_module /usr/lib/httpd/mod_env.so
|
||||
LoadModule define_module /usr/lib/httpd/mod_define.so
|
||||
LoadModule config_log_module /usr/lib/httpd/mod_log_config.so
|
||||
#LoadModule agent_log_module /usr/lib/httpd/mod_log_agent.so
|
||||
#LoadModule referer_log_module /usr/lib/httpd/mod_log_referer.so
|
||||
#LoadModule mime_magic_module /usr/lib/httpd/mod_mime_magic.so
|
||||
LoadModule mime_module /usr/lib/httpd/mod_mime.so
|
||||
LoadModule negotiation_module /usr/lib/httpd/mod_negotiation.so
|
||||
LoadModule status_module /usr/lib/httpd/mod_status.so
|
||||
LoadModule info_module /usr/lib/httpd/mod_info.so
|
||||
LoadModule includes_module /usr/lib/httpd/mod_include.so
|
||||
LoadModule autoindex_module /usr/lib/httpd/mod_autoindex.so
|
||||
LoadModule dir_module /usr/lib/httpd/mod_dir.so
|
||||
LoadModule cgi_module /usr/lib/httpd/mod_cgi.so
|
||||
#LoadModule asis_module /usr/lib/httpd/mod_asis.so
|
||||
LoadModule imap_module /usr/lib/httpd/mod_imap.so
|
||||
LoadModule action_module /usr/lib/httpd/mod_actions.so
|
||||
#LoadModule speling_module /usr/lib/httpd/mod_speling.so
|
||||
LoadModule userdir_module /usr/lib/httpd/mod_userdir.so
|
||||
LoadModule alias_module /usr/lib/httpd/mod_alias.so
|
||||
LoadModule rewrite_module /usr/lib/httpd/mod_rewrite.so
|
||||
LoadModule access_module /usr/lib/httpd/mod_access.so
|
||||
LoadModule auth_module /usr/lib/httpd/mod_auth.so
|
||||
#LoadModule anon_auth_module /usr/lib/httpd/mod_auth_anon.so
|
||||
#LoadModule dbm_auth_module /usr/lib/httpd/mod_auth_dbm.so
|
||||
#LoadModule db_auth_module /usr/lib/httpd/mod_auth_db.so
|
||||
#LoadModule digest_module /usr/lib/httpd/mod_digest.so
|
||||
#LoadModule proxy_module /usr/lib/httpd/libproxy.so
|
||||
#LoadModule cern_meta_module /usr/lib/httpd/mod_cern_meta.so
|
||||
#LoadModule expires_module /usr/lib/httpd/mod_expires.so
|
||||
#LoadModule headers_module /usr/lib/httpd/mod_headers.so
|
||||
LoadModule usertrack_module /usr/lib/httpd/mod_usertrack.so
|
||||
#LoadModule example_module /usr/lib/httpd/mod_example.so
|
||||
#LoadModule unique_id_module /usr/lib/httpd/mod_unique_id.so
|
||||
LoadModule setenvif_module /usr/lib/httpd/mod_setenvif.so
|
||||
#LoadModule ssl_module /usr/lib/httpd/libssl.so
|
||||
LoadModule perl_module /usr/lib/httpd/libperl.so
|
||||
#LoadModule php4_module /usr/lib/httpd/libphp4.so
|
||||
#LoadModule gzip_module /usr/lib/httpd/mod_gzip.so
|
||||
#LoadModule throttle_module /usr/lib/httpd/mod_throttle.so
|
||||
#LoadModule backhand_module /usr/lib/httpd/mod_backhand.so
|
||||
|
||||
# This list below must correspond with the list of modules you have
|
||||
# enabled above.
|
||||
|
||||
ClearModuleList
|
||||
#AddModule mod_mmap_static.c
|
||||
#AddModule mod_vhost_alias.c
|
||||
AddModule mod_env.c
|
||||
AddModule mod_define.c
|
||||
AddModule mod_log_config.c
|
||||
#AddModule mod_log_agent.c
|
||||
#AddModule mod_log_referer.c
|
||||
#AddModule mod_mime_magic.c
|
||||
AddModule mod_mime.c
|
||||
AddModule mod_negotiation.c
|
||||
AddModule mod_status.c
|
||||
AddModule mod_info.c
|
||||
AddModule mod_include.c
|
||||
AddModule mod_autoindex.c
|
||||
AddModule mod_dir.c
|
||||
AddModule mod_cgi.c
|
||||
#AddModule mod_asis.c
|
||||
AddModule mod_imap.c
|
||||
AddModule mod_actions.c
|
||||
#AddModule mod_speling.c
|
||||
AddModule mod_userdir.c
|
||||
AddModule mod_alias.c
|
||||
AddModule mod_rewrite.c
|
||||
AddModule mod_access.c
|
||||
AddModule mod_auth.c
|
||||
#AddModule mod_auth_anon.c
|
||||
#AddModule mod_auth_dbm.c
|
||||
#AddModule mod_auth_db.c
|
||||
#AddModule mod_digest.c
|
||||
#AddModule mod_proxy.c
|
||||
#AddModule mod_cern_meta.c
|
||||
#AddModule mod_expires.c
|
||||
#AddModule mod_headers.c
|
||||
AddModule mod_usertrack.c
|
||||
#AddModule mod_example.c
|
||||
#AddModule mod_unique_id.c
|
||||
AddModule mod_so.c
|
||||
AddModule mod_setenvif.c
|
||||
#AddModule mod_ssl.c
|
||||
AddModule mod_perl.c
|
||||
#AddModule mod_php4.c
|
||||
#AddModule mod_gzip.c
|
||||
#AddModule mod_throttle.c
|
||||
#AddModule mod_backhand.c
|
||||
|
||||
# Section 2: Main Server Configuration
|
||||
ServerAdmin webmaster@forum.slowtwitch.com
|
||||
#Include /etc/httpd/forum_servername.conf
|
||||
UseCanonicalName Off
|
||||
|
||||
DirectoryIndex index.html index.htm default.htm index.shtm index.shtml index.cgi index.php
|
||||
AccessFileName .htaccess
|
||||
TypesConfig /var/home/slowtwitch/forum.slowtwitch.com/modperl.mime_types
|
||||
DefaultType text/plain
|
||||
ExtendedStatus On
|
||||
ServerSignature Off
|
||||
ServerTokens ProductOnly
|
||||
|
||||
# Do not enable hostname lookups, ip's will be looked up nightly
|
||||
# and will be replaced with the hostname in the log files.
|
||||
HostnameLookups Off
|
||||
|
||||
# Logging Directives
|
||||
LogLevel warn
|
||||
LogFormat "%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-Agent}i\"" combined
|
||||
LogFormat "%h %l %u %t \"%r\" %>s %b" common
|
||||
LogFormat "%{Referer}i -> %U" referer
|
||||
LogFormat "%{User-agent}i" agent
|
||||
CustomLog /var/home/slowtwitch/forum.slowtwitch.com/logs/perl_access_log combined
|
||||
ErrorLog /var/home/slowtwitch/forum.slowtwitch.com/logs/perl_error_log
|
||||
|
||||
# Default Handlers
|
||||
AddType text/html .shtm .shtml
|
||||
AddHandler cgi-script .cgi
|
||||
AddHandler server-parsed .htm .html .shtm .shtml
|
||||
AddHandler send-as-is asis
|
||||
AddHandler imap-file map
|
||||
|
||||
# Root Filesystem
|
||||
<Directory />
|
||||
Options FollowSymLinks
|
||||
AllowOverride None
|
||||
</Directory>
|
||||
|
||||
# Document Root
|
||||
<Directory /var/home/slowtwitch/forum.slowtwitch.com/>
|
||||
Options All -Indexes
|
||||
AllowOverride All
|
||||
</Directory>
|
||||
|
||||
# Disallow any attempts at viewing .ht* files
|
||||
<Files ~ "^\.ht">
|
||||
Order allow,deny
|
||||
Deny from all
|
||||
Satisfy All
|
||||
</Files>
|
||||
|
||||
# Setup /icons/ alias
|
||||
Alias /icons/ /var/httpd/icons/
|
||||
<Location /icons/>
|
||||
Options MultiViews
|
||||
AllowOverride None
|
||||
Order allow,deny
|
||||
Allow from all
|
||||
</Location>
|
||||
|
||||
# View server status information
|
||||
<Location /server-status>
|
||||
# Protect this information from prying eyes
|
||||
AuthType Basic
|
||||
AuthName Protected
|
||||
AuthUserFile /home/slowtwitch/.gpanel/status_htpasswd
|
||||
require valid-user
|
||||
|
||||
SetHandler server-status
|
||||
Order deny,allow
|
||||
Deny from all
|
||||
Allow from localhost
|
||||
</Location>
|
||||
|
||||
# View perl info
|
||||
<Location /perl-status>
|
||||
# Protect this information from prying eyes
|
||||
AuthType Basic
|
||||
AuthName Protected
|
||||
AuthUserFile /home/slowtwitch/.gpanel/status_htpasswd
|
||||
require valid-user
|
||||
|
||||
SetHandler perl-script
|
||||
PerlHandler Apache::Status
|
||||
Order deny,allow
|
||||
Deny from all
|
||||
Allow from localhost
|
||||
</Location>
|
||||
|
||||
# Directory Indexing and Content Negotiation Options
|
||||
IndexOptions FancyIndexing
|
||||
AddIconByEncoding (CMP,/icons/compressed.gif) x-compress x-gzip
|
||||
AddIconByType (TXT,/icons/text.gif) text/*
|
||||
AddIconByType (IMG,/icons/image2.gif) image/*
|
||||
AddIconByType (SND,/icons/sound2.gif) audio/*
|
||||
AddIconByType (VID,/icons/movie.gif) video/*
|
||||
AddIcon /icons/binary.gif .bin .exe
|
||||
AddIcon /icons/binhex.gif .hqx
|
||||
AddIcon /icons/tar.gif .tar
|
||||
AddIcon /icons/world2.gif .wrl .wrl.gz .vrml .vrm .iv
|
||||
AddIcon /icons/compressed.gif .Z .z .tgz .gz .zip
|
||||
AddIcon /icons/a.gif .ps .ai .eps
|
||||
AddIcon /icons/layout.gif .html .shtml .htm .pdf
|
||||
AddIcon /icons/text.gif .txt
|
||||
AddIcon /icons/c.gif .c
|
||||
AddIcon /icons/p.gif .pl .py
|
||||
AddIcon /icons/f.gif .for
|
||||
AddIcon /icons/dvi.gif .dvi
|
||||
AddIcon /icons/uuencoded.gif .uu
|
||||
AddIcon /icons/script.gif .conf .sh .shar .csh .ksh .tcl
|
||||
AddIcon /icons/tex.gif .tex
|
||||
AddIcon /icons/bomb.gif core
|
||||
AddIcon /icons/back.gif ..
|
||||
AddIcon /icons/hand.right.gif README
|
||||
AddIcon /icons/folder.gif ^^DIRECTORY^^
|
||||
AddIcon /icons/blank.gif ^^BLANKICON^^
|
||||
DefaultIcon /icons/unknown.gif
|
||||
ReadmeName README
|
||||
HeaderName HEADER
|
||||
IndexIgnore .??* *~ *# HEADER* README* RCS CVS *,v *,t
|
||||
AddEncoding x-compress Z
|
||||
AddEncoding x-gzip gz tgz
|
||||
AddLanguage da .dk
|
||||
AddLanguage nl .nl
|
||||
AddLanguage en .en
|
||||
AddLanguage et .ee
|
||||
AddLanguage fr .fr
|
||||
AddLanguage de .de
|
||||
AddLanguage el .el
|
||||
AddLanguage he .he
|
||||
AddCharset ISO-8859-8 .iso8859-8
|
||||
AddLanguage it .it
|
||||
AddLanguage ja .ja
|
||||
AddCharset ISO-2022-JP .jis
|
||||
AddLanguage kr .kr
|
||||
AddCharset ISO-2022-KR .iso-kr
|
||||
AddLanguage nn .nn
|
||||
AddLanguage no .no
|
||||
AddLanguage pl .po
|
||||
AddCharset ISO-8859-2 .iso-pl
|
||||
AddLanguage pt .pt
|
||||
AddLanguage pt-br .pt-br
|
||||
AddLanguage ltz .lu
|
||||
AddLanguage ca .ca
|
||||
AddLanguage es .es
|
||||
AddLanguage sv .sv
|
||||
AddLanguage cz .cz
|
||||
AddLanguage ru .ru
|
||||
AddLanguage zh-tw .tw
|
||||
AddLanguage tw .tw
|
||||
AddCharset Big5 .Big5 .big5
|
||||
AddCharset WINDOWS-1251 .cp-1251
|
||||
AddCharset CP866 .cp866
|
||||
AddCharset ISO-8859-5 .iso-ru
|
||||
AddCharset KOI8-R .koi8-r
|
||||
AddCharset UCS-2 .ucs2
|
||||
AddCharset UCS-4 .ucs4
|
||||
AddCharset UTF-8 .utf8
|
||||
LanguagePriority en da nl et fr de el it ja kr no pl pt pt-br ru ltz ca es sv tw
|
||||
AddType application/x-tar .tgz
|
||||
|
||||
#Include /etc/httpd/forum_backhand.conf
|
||||
|
||||
# Load the mod_perl startup file, and setup the mod_perl handler so that
|
||||
# the ip address is updated for all requests.
|
||||
PerlRequire /var/home/slowtwitch/forum.slowtwitch.com/modperl_startup.pl
|
||||
PerlPostReadRequestHandler My::ProxyRemoteAddr
|
||||
|
||||
# By default only scripts in /perl/ are executed under mod_perl.
|
||||
Alias /perl/ /var/home/slowtwitch/forum.slowtwitch.com/perl/
|
||||
<Directory /var/home/slowtwitch/forum.slowtwitch.com/perl/>
|
||||
Order Allow,Deny
|
||||
Allow From All
|
||||
AllowOverride All
|
||||
Options +ExecCGI
|
||||
|
||||
SetHandler perl-script
|
||||
PerlHandler Apache::Registry
|
||||
PerlSendHeader On
|
||||
</Directory>
|
||||
|
||||
# If you want your /cgi-bin/ to be run under mod_perl, uncomment
|
||||
# the following:
|
||||
Alias /cgi-bin/ /var/home/slowtwitch/forum.slowtwitch.com/cgi-bin/
|
||||
<Directory /var/home/slowtwitch/forum.slowtwitch.com/cgi-bin/>
|
||||
Order Allow,Deny
|
||||
Allow From All
|
||||
AllowOverride All
|
||||
Options +ExecCGI
|
||||
|
||||
SetHandler perl-script
|
||||
PerlHandler Apache::Registry
|
||||
PerlSendHeader On
|
||||
</Directory>
|
||||
|
||||
# vim:syn=apache:sw=4:et
|
||||
|
||||
|
||||
469
forum.slowtwitch.com/modperl.mime_types
Normal file
469
forum.slowtwitch.com/modperl.mime_types
Normal file
@ -0,0 +1,469 @@
|
||||
# This is a comment. I love comments.
|
||||
|
||||
# This file controls what Internet media types are sent to the client for
|
||||
# given file extension(s). Sending the correct media type to the client
|
||||
# is important so they know how to handle the content of the file.
|
||||
# Extra types can either be added here or by using an AddType directive
|
||||
# in your config files. For more information about Internet media types,
|
||||
# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type
|
||||
# registry is at <ftp://ftp.iana.org/in-notes/iana/assignments/media-types/>.
|
||||
|
||||
# MIME type Extension
|
||||
application/EDI-Consent
|
||||
application/EDI-X12
|
||||
application/EDIFACT
|
||||
application/activemessage
|
||||
application/andrew-inset ez
|
||||
application/applefile
|
||||
application/atomicmail
|
||||
application/batch-SMTP
|
||||
application/beep+xml
|
||||
application/cals-1840
|
||||
application/commonground
|
||||
application/cybercash
|
||||
application/dca-rft
|
||||
application/dec-dx
|
||||
application/dvcs
|
||||
application/eshop
|
||||
application/http
|
||||
application/hyperstudio
|
||||
application/iges
|
||||
application/index
|
||||
application/index.cmd
|
||||
application/index.obj
|
||||
application/index.response
|
||||
application/index.vnd
|
||||
application/iotp
|
||||
application/ipp
|
||||
application/isup
|
||||
application/font-tdpfr
|
||||
application/mac-binhex40 hqx
|
||||
application/mac-compactpro cpt
|
||||
application/macwriteii
|
||||
application/marc
|
||||
application/mathematica
|
||||
application/mathematica-old
|
||||
application/msword doc
|
||||
application/news-message-id
|
||||
application/news-transmission
|
||||
application/ocsp-request
|
||||
application/ocsp-response
|
||||
application/octet-stream bin dms lha lzh exe class so dll
|
||||
application/oda oda
|
||||
application/parityfec
|
||||
application/pdf pdf
|
||||
application/pgp-encrypted
|
||||
application/pgp-keys
|
||||
application/pgp-signature
|
||||
application/pkcs10
|
||||
application/pkcs7-mime
|
||||
application/pkcs7-signature
|
||||
application/pkix-cert
|
||||
application/pkix-crl
|
||||
application/pkixcmp
|
||||
application/postscript ai eps ps
|
||||
application/prs.alvestrand.titrax-sheet
|
||||
application/prs.cww
|
||||
application/prs.nprend
|
||||
application/qsig
|
||||
application/remote-printing
|
||||
application/riscos
|
||||
application/rtf
|
||||
application/sdp
|
||||
application/set-payment
|
||||
application/set-payment-initiation
|
||||
application/set-registration
|
||||
application/set-registration-initiation
|
||||
application/sgml
|
||||
application/sgml-open-catalog
|
||||
application/sieve
|
||||
application/slate
|
||||
application/smil smi smil
|
||||
application/timestamp-query
|
||||
application/timestamp-reply
|
||||
application/vemmi
|
||||
application/vnd.3M.Post-it-Notes
|
||||
application/vnd.FloGraphIt
|
||||
application/vnd.accpac.simply.aso
|
||||
application/vnd.accpac.simply.imp
|
||||
application/vnd.acucobol
|
||||
application/vnd.aether.imp
|
||||
application/vnd.anser-web-certificate-issue-initiation
|
||||
application/vnd.anser-web-funds-transfer-initiation
|
||||
application/vnd.audiograph
|
||||
application/vnd.businessobjects
|
||||
application/vnd.bmi
|
||||
application/vnd.canon-cpdl
|
||||
application/vnd.canon-lips
|
||||
application/vnd.claymore
|
||||
application/vnd.commerce-battelle
|
||||
application/vnd.commonspace
|
||||
application/vnd.comsocaller
|
||||
application/vnd.contact.cmsg
|
||||
application/vnd.cosmocaller
|
||||
application/vnd.cups-postscript
|
||||
application/vnd.cups-raster
|
||||
application/vnd.cups-raw
|
||||
application/vnd.ctc-posml
|
||||
application/vnd.cybank
|
||||
application/vnd.dna
|
||||
application/vnd.dpgraph
|
||||
application/vnd.dxr
|
||||
application/vnd.ecdis-update
|
||||
application/vnd.ecowin.chart
|
||||
application/vnd.ecowin.filerequest
|
||||
application/vnd.ecowin.fileupdate
|
||||
application/vnd.ecowin.series
|
||||
application/vnd.ecowin.seriesrequest
|
||||
application/vnd.ecowin.seriesupdate
|
||||
application/vnd.enliven
|
||||
application/vnd.epson.esf
|
||||
application/vnd.epson.msf
|
||||
application/vnd.epson.quickanime
|
||||
application/vnd.epson.salt
|
||||
application/vnd.epson.ssf
|
||||
application/vnd.ericsson.quickcall
|
||||
application/vnd.eudora.data
|
||||
application/vnd.fdf
|
||||
application/vnd.ffsns
|
||||
application/vnd.framemaker
|
||||
application/vnd.fsc.weblaunch
|
||||
application/vnd.fujitsu.oasys
|
||||
application/vnd.fujitsu.oasys2
|
||||
application/vnd.fujitsu.oasys3
|
||||
application/vnd.fujitsu.oasysgp
|
||||
application/vnd.fujitsu.oasysprs
|
||||
application/vnd.fujixerox.ddd
|
||||
application/vnd.fujixerox.docuworks
|
||||
application/vnd.fujixerox.docuworks.binder
|
||||
application/vnd.fut-misnet
|
||||
application/vnd.grafeq
|
||||
application/vnd.groove-account
|
||||
application/vnd.groove-identity-message
|
||||
application/vnd.groove-injector
|
||||
application/vnd.groove-tool-message
|
||||
application/vnd.groove-tool-template
|
||||
application/vnd.groove-vcard
|
||||
application/vnd.hhe.lesson-player
|
||||
application/vnd.hp-HPGL
|
||||
application/vnd.hp-PCL
|
||||
application/vnd.hp-PCLXL
|
||||
application/vnd.hp-hpid
|
||||
application/vnd.hp-hps
|
||||
application/vnd.httphone
|
||||
application/vnd.hzn-3d-crossword
|
||||
application/vnd.ibm.afplinedata
|
||||
application/vnd.ibm.MiniPay
|
||||
application/vnd.ibm.modcap
|
||||
application/vnd.informix-visionary
|
||||
application/vnd.intercon.formnet
|
||||
application/vnd.intertrust.digibox
|
||||
application/vnd.intertrust.nncp
|
||||
application/vnd.intu.qbo
|
||||
application/vnd.intu.qfx
|
||||
application/vnd.irepository.package+xml
|
||||
application/vnd.is-xpr
|
||||
application/vnd.japannet-directory-service
|
||||
application/vnd.japannet-jpnstore-wakeup
|
||||
application/vnd.japannet-payment-wakeup
|
||||
application/vnd.japannet-registration
|
||||
application/vnd.japannet-registration-wakeup
|
||||
application/vnd.japannet-setstore-wakeup
|
||||
application/vnd.japannet-verification
|
||||
application/vnd.japannet-verification-wakeup
|
||||
application/vnd.koan
|
||||
application/vnd.lotus-1-2-3
|
||||
application/vnd.lotus-approach
|
||||
application/vnd.lotus-freelance
|
||||
application/vnd.lotus-notes
|
||||
application/vnd.lotus-organizer
|
||||
application/vnd.lotus-screencam
|
||||
application/vnd.lotus-wordpro
|
||||
application/vnd.mcd
|
||||
application/vnd.mediastation.cdkey
|
||||
application/vnd.meridian-slingshot
|
||||
application/vnd.mif mif
|
||||
application/vnd.minisoft-hp3000-save
|
||||
application/vnd.mitsubishi.misty-guard.trustweb
|
||||
application/vnd.mobius.daf
|
||||
application/vnd.mobius.dis
|
||||
application/vnd.mobius.msl
|
||||
application/vnd.mobius.plc
|
||||
application/vnd.mobius.txf
|
||||
application/vnd.motorola.flexsuite
|
||||
application/vnd.motorola.flexsuite.adsi
|
||||
application/vnd.motorola.flexsuite.fis
|
||||
application/vnd.motorola.flexsuite.gotap
|
||||
application/vnd.motorola.flexsuite.kmr
|
||||
application/vnd.motorola.flexsuite.ttc
|
||||
application/vnd.motorola.flexsuite.wem
|
||||
application/vnd.mozilla.xul+xml
|
||||
application/vnd.ms-artgalry
|
||||
application/vnd.ms-asf
|
||||
application/vnd.ms-excel xls
|
||||
application/vnd.ms-lrm
|
||||
application/vnd.ms-powerpoint ppt
|
||||
application/vnd.ms-project
|
||||
application/vnd.ms-tnef
|
||||
application/vnd.ms-works
|
||||
application/vnd.mseq
|
||||
application/vnd.msign
|
||||
application/vnd.music-niff
|
||||
application/vnd.musician
|
||||
application/vnd.netfpx
|
||||
application/vnd.noblenet-directory
|
||||
application/vnd.noblenet-sealer
|
||||
application/vnd.noblenet-web
|
||||
application/vnd.novadigm.EDM
|
||||
application/vnd.novadigm.EDX
|
||||
application/vnd.novadigm.EXT
|
||||
application/vnd.osa.netdeploy
|
||||
application/vnd.palm
|
||||
application/vnd.pg.format
|
||||
application/vnd.pg.osasli
|
||||
application/vnd.powerbuilder6
|
||||
application/vnd.powerbuilder6-s
|
||||
application/vnd.powerbuilder7
|
||||
application/vnd.powerbuilder7-s
|
||||
application/vnd.powerbuilder75
|
||||
application/vnd.powerbuilder75-s
|
||||
application/vnd.previewsystems.box
|
||||
application/vnd.publishare-delta-tree
|
||||
application/vnd.pvi.ptid1
|
||||
application/vnd.pwg-xhtml-print+xml
|
||||
application/vnd.rapid
|
||||
application/vnd.s3sms
|
||||
application/vnd.seemail
|
||||
application/vnd.shana.informed.formdata
|
||||
application/vnd.shana.informed.formtemplate
|
||||
application/vnd.shana.informed.interchange
|
||||
application/vnd.shana.informed.package
|
||||
application/vnd.sss-cod
|
||||
application/vnd.sss-dtf
|
||||
application/vnd.sss-ntf
|
||||
application/vnd.street-stream
|
||||
application/vnd.svd
|
||||
application/vnd.swiftview-ics
|
||||
application/vnd.triscape.mxs
|
||||
application/vnd.trueapp
|
||||
application/vnd.truedoc
|
||||
application/vnd.tve-trigger
|
||||
application/vnd.ufdl
|
||||
application/vnd.uplanet.alert
|
||||
application/vnd.uplanet.alert-wbxml
|
||||
application/vnd.uplanet.bearer-choice-wbxml
|
||||
application/vnd.uplanet.bearer-choice
|
||||
application/vnd.uplanet.cacheop
|
||||
application/vnd.uplanet.cacheop-wbxml
|
||||
application/vnd.uplanet.channel
|
||||
application/vnd.uplanet.channel-wbxml
|
||||
application/vnd.uplanet.list
|
||||
application/vnd.uplanet.list-wbxml
|
||||
application/vnd.uplanet.listcmd
|
||||
application/vnd.uplanet.listcmd-wbxml
|
||||
application/vnd.uplanet.signal
|
||||
application/vnd.vcx
|
||||
application/vnd.vectorworks
|
||||
application/vnd.vidsoft.vidconference
|
||||
application/vnd.visio
|
||||
application/vnd.vividence.scriptfile
|
||||
application/vnd.wap.sic
|
||||
application/vnd.wap.slc
|
||||
application/vnd.wap.wbxml wbxml
|
||||
application/vnd.wap.wmlc wmlc
|
||||
application/vnd.wap.wmlscriptc wmlsc
|
||||
application/vnd.webturbo
|
||||
application/vnd.wrq-hp3000-labelled
|
||||
application/vnd.wt.stf
|
||||
application/vnd.xara
|
||||
application/vnd.xfdl
|
||||
application/vnd.yellowriver-custom-menu
|
||||
application/whoispp-query
|
||||
application/whoispp-response
|
||||
application/wita
|
||||
application/wordperfect5.1
|
||||
application/x-bcpio bcpio
|
||||
application/x-cdlink vcd
|
||||
application/x-chess-pgn pgn
|
||||
application/x-compress
|
||||
application/x-cpio cpio
|
||||
application/x-csh csh
|
||||
application/x-director dcr dir dxr
|
||||
application/x-dvi dvi
|
||||
application/x-futuresplash spl
|
||||
application/x-gtar gtar
|
||||
application/x-gzip
|
||||
application/x-hdf hdf
|
||||
application/x-javascript js
|
||||
application/x-koan skp skd skt skm
|
||||
application/x-latex latex
|
||||
application/x-netcdf nc cdf
|
||||
application/x-sh sh
|
||||
application/x-shar shar
|
||||
application/x-shockwave-flash swf
|
||||
application/x-stuffit sit
|
||||
application/x-sv4cpio sv4cpio
|
||||
application/x-sv4crc sv4crc
|
||||
application/x-tar tar
|
||||
application/x-tcl tcl
|
||||
application/x-tex tex
|
||||
application/x-texinfo texinfo texi
|
||||
application/x-troff t tr roff
|
||||
application/x-troff-man man
|
||||
application/x-troff-me me
|
||||
application/x-troff-ms ms
|
||||
application/x-ustar ustar
|
||||
application/x-wais-source src
|
||||
application/x400-bp
|
||||
application/xml
|
||||
application/xml-dtd
|
||||
application/xml-external-parsed-entity
|
||||
application/zip zip
|
||||
audio/32kadpcm
|
||||
audio/basic au snd
|
||||
audio/g.722.1
|
||||
audio/l16
|
||||
audio/midi mid midi kar
|
||||
audio/mp4a-latm
|
||||
audio/mpa-robust
|
||||
audio/mpeg mpga mp2 mp3
|
||||
audio/parityfec
|
||||
audio/prs.sid
|
||||
audio/telephone-event
|
||||
audio/tone
|
||||
audio/vnd.cisco.nse
|
||||
audio/vnd.cns.anp1
|
||||
audio/vnd.cns.inf1
|
||||
audio/vnd.digital-winds
|
||||
audio/vnd.everad.plj
|
||||
audio/vnd.lucent.voice
|
||||
audio/vnd.nortel.vbk
|
||||
audio/vnd.nuera.ecelp4800
|
||||
audio/vnd.nuera.ecelp7470
|
||||
audio/vnd.nuera.ecelp9600
|
||||
audio/vnd.octel.sbc
|
||||
audio/vnd.qcelp
|
||||
audio/vnd.rhetorex.32kadpcm
|
||||
audio/vnd.vmx.cvsd
|
||||
audio/x-aiff aif aiff aifc
|
||||
audio/x-mpegurl m3u
|
||||
audio/x-pn-realaudio ram rm
|
||||
audio/x-pn-realaudio-plugin rpm
|
||||
audio/x-realaudio ra
|
||||
audio/x-wav wav
|
||||
chemical/x-pdb pdb
|
||||
chemical/x-xyz xyz
|
||||
image/bmp bmp
|
||||
image/cgm
|
||||
image/g3fax
|
||||
image/gif gif
|
||||
image/ief ief
|
||||
image/jpeg jpeg jpg jpe
|
||||
image/naplps
|
||||
image/png png
|
||||
image/prs.btif
|
||||
image/prs.pti
|
||||
image/tiff tiff tif
|
||||
image/vnd.cns.inf2
|
||||
image/vnd.dwg
|
||||
image/vnd.dxf
|
||||
image/vnd.fastbidsheet
|
||||
image/vnd.fpx
|
||||
image/vnd.fst
|
||||
image/vnd.fujixerox.edmics-mmr
|
||||
image/vnd.fujixerox.edmics-rlc
|
||||
image/vnd.mix
|
||||
image/vnd.net-fpx
|
||||
image/vnd.svf
|
||||
image/vnd.wap.wbmp wbmp
|
||||
image/vnd.xiff
|
||||
image/x-cmu-raster ras
|
||||
image/x-portable-anymap pnm
|
||||
image/x-portable-bitmap pbm
|
||||
image/x-portable-graymap pgm
|
||||
image/x-portable-pixmap ppm
|
||||
image/x-rgb rgb
|
||||
image/x-xbitmap xbm
|
||||
image/x-xpixmap xpm
|
||||
image/x-xwindowdump xwd
|
||||
message/delivery-status
|
||||
message/disposition-notification
|
||||
message/external-body
|
||||
message/http
|
||||
message/news
|
||||
message/partial
|
||||
message/rfc822
|
||||
message/s-http
|
||||
model/iges igs iges
|
||||
model/mesh msh mesh silo
|
||||
model/vnd.dwf
|
||||
model/vnd.flatland.3dml
|
||||
model/vnd.gdl
|
||||
model/vnd.gs-gdl
|
||||
model/vnd.gtw
|
||||
model/vnd.mts
|
||||
model/vnd.vtu
|
||||
model/vrml wrl vrml
|
||||
multipart/alternative
|
||||
multipart/appledouble
|
||||
multipart/byteranges
|
||||
multipart/digest
|
||||
multipart/encrypted
|
||||
multipart/form-data
|
||||
multipart/header-set
|
||||
multipart/mixed
|
||||
multipart/parallel
|
||||
multipart/related
|
||||
multipart/report
|
||||
multipart/signed
|
||||
multipart/voice-message
|
||||
text/calendar
|
||||
text/css css
|
||||
text/directory
|
||||
text/enriched
|
||||
text/html html htm
|
||||
text/parityfec
|
||||
text/plain asc txt
|
||||
text/prs.lines.tag
|
||||
text/rfc822-headers
|
||||
text/richtext rtx
|
||||
text/rtf rtf
|
||||
text/sgml sgml sgm
|
||||
text/tab-separated-values tsv
|
||||
text/t140
|
||||
text/uri-list
|
||||
text/vnd.DMClientScript
|
||||
text/vnd.IPTC.NITF
|
||||
text/vnd.IPTC.NewsML
|
||||
text/vnd.abc
|
||||
text/vnd.curl
|
||||
text/vnd.flatland.3dml
|
||||
text/vnd.fly
|
||||
text/vnd.fmi.flexstor
|
||||
text/vnd.in3d.3dml
|
||||
text/vnd.in3d.spot
|
||||
text/vnd.latex-z
|
||||
text/vnd.motorola.reflex
|
||||
text/vnd.ms-mediapackage
|
||||
text/vnd.wap.si
|
||||
text/vnd.wap.sl
|
||||
text/vnd.wap.wml wml
|
||||
text/vnd.wap.wmlscript wmls
|
||||
text/x-setext etx
|
||||
text/xml xml xsl
|
||||
text/xml-external-parsed-entity
|
||||
video/mp4v-es
|
||||
video/mpeg mpeg mpg mpe
|
||||
video/parityfec
|
||||
video/pointer
|
||||
video/quicktime qt mov
|
||||
video/vnd.fvt
|
||||
video/vnd.motorola.video
|
||||
video/vnd.motorola.videop
|
||||
video/vnd.mpegurl mxu
|
||||
video/vnd.mts
|
||||
video/vnd.nokia.interleaved-multimedia
|
||||
video/vnd.vivo
|
||||
video/x-msvideo avi
|
||||
video/x-sgi-movie movie
|
||||
x-conference/x-cooltalk ice
|
||||
35
forum.slowtwitch.com/modperl_startup.pl
Executable file
35
forum.slowtwitch.com/modperl_startup.pl
Executable file
@ -0,0 +1,35 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# mod_perl startup file.
|
||||
#
|
||||
# This file is used for pre-loading perl code for use under
|
||||
# Apache::Registry, or for creating mod_perl handlers. See:
|
||||
#
|
||||
# http://perl.apache.org/guide/
|
||||
#
|
||||
# for more information.
|
||||
#
|
||||
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum::mod_perl;
|
||||
|
||||
# Automatically fix up the REMOTE_IP environment variable.
|
||||
|
||||
sub My::ProxyRemoteAddr ($) {
|
||||
# ------------------------------------------------
|
||||
my $r = shift;
|
||||
my $ip = $r->connection->remote_ip;
|
||||
unless ($ip eq '127.0.0.1') {
|
||||
return OK;
|
||||
}
|
||||
# Select last value in the chain -- original client's ip
|
||||
if (my ($ip) = $r->headers_in->{'X-Forwarded-For'} =~ /([^,\s]+)$/) {
|
||||
$r->connection->remote_ip($ip);
|
||||
}
|
||||
return OK;
|
||||
}
|
||||
|
||||
|
||||
# Must return a true value
|
||||
1;
|
||||
|
||||
35
forum.slowtwitch.com/modperl_startup.pl.bak
Executable file
35
forum.slowtwitch.com/modperl_startup.pl.bak
Executable file
@ -0,0 +1,35 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# mod_perl startup file.
|
||||
#
|
||||
# This file is used for pre-loading perl code for use under
|
||||
# Apache::Registry, or for creating mod_perl handlers. See:
|
||||
#
|
||||
# http://perl.apache.org/guide/
|
||||
#
|
||||
# for more information.
|
||||
#
|
||||
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum::mod_perl;
|
||||
|
||||
# Automatically fix up the REMOTE_IP environment variable.
|
||||
|
||||
sub My::ProxyRemoteAddr ($) {
|
||||
# ------------------------------------------------
|
||||
my $r = shift;
|
||||
my $ip = $r->connection->remote_ip;
|
||||
unless ($ip eq '127.0.0.1') {
|
||||
return OK;
|
||||
}
|
||||
# Select last value in the chain -- original client's ip
|
||||
if (my ($ip) = $r->headers_in->{'X-Forwarded-For'} =~ /([^,\s]+)$/) {
|
||||
$r->connection->remote_ip($ip);
|
||||
}
|
||||
return OK;
|
||||
}
|
||||
|
||||
|
||||
# Must return a true value
|
||||
1;
|
||||
|
||||
4
forum.slowtwitch.com/modperlctl
Executable file
4
forum.slowtwitch.com/modperlctl
Executable file
@ -0,0 +1,4 @@
|
||||
#!/bin/sh
|
||||
|
||||
exec /usr/sbin/service modperl "$*" forum.slowtwitch.com
|
||||
|
||||
143
site/common/bin/minify.cgi
Executable file
143
site/common/bin/minify.cgi
Executable file
@ -0,0 +1,143 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use FindBin qw/$Bin/;
|
||||
FindBin::again;
|
||||
|
||||
use lib "$Bin/../admin";
|
||||
use GForum qw/$IN $CFG $DB %STASH/;
|
||||
GForum::init("$Bin/../admin");
|
||||
|
||||
$STASH{admin_request} = 1;
|
||||
|
||||
$|++;
|
||||
|
||||
use constant HOME => "/home/slowtwitch/site/common";
|
||||
|
||||
our $YUI_COMP = HOME . '/bin/yuicompressor-2.4.8.jar';
|
||||
our $GOOGLE_CLOSURE = HOME . '/bin/compiler.jar';
|
||||
|
||||
our %CSS = (
|
||||
'core.css' => 'core.min.css',
|
||||
'forum.css' => 'forum.min.css',
|
||||
'print.css' => 'print.min.css'
|
||||
);
|
||||
our %CSS_APPEND = (
|
||||
'forum.css' => [
|
||||
'jquery-ui.min.css',
|
||||
'lightbox.min.css',
|
||||
'core.min.css',
|
||||
]
|
||||
);
|
||||
|
||||
|
||||
# These must be in the static/js directory, and get placed into
|
||||
# static/js/file.min.js
|
||||
our %JS = (
|
||||
'gforum.js' => 'gforum.min.js',
|
||||
'utils.js' => 'utils.min.js',
|
||||
'core.js' => 'base.min.js'
|
||||
);
|
||||
our %JS_APPEND = (
|
||||
'core.js' => [
|
||||
'jquery.min.js',
|
||||
'jquery-ui.min.js',
|
||||
'jquery.form.min.js',
|
||||
'jquery.jcarousellite.min.js',
|
||||
'jquery.autocomplete.min.js'
|
||||
],
|
||||
'gforum.js' => [
|
||||
'utils.min.js'
|
||||
]
|
||||
);
|
||||
|
||||
print $IN->header, "<pre>";
|
||||
main();
|
||||
|
||||
sub main {
|
||||
# -------------------------------------------------------------------
|
||||
print "Creating css files ... \n";
|
||||
for my $css (keys %CSS) {
|
||||
print " $css => $CSS{$css} ... \n";
|
||||
my $full_path = HOME . "/static/css/$css";
|
||||
my $output = HOME . "/static/css/$CSS{$css}";
|
||||
if (! -e $full_path) {
|
||||
die "Missing css file $full_path";
|
||||
}
|
||||
if ($CSS_APPEND{$css}) {
|
||||
open my $fh, ">", "$full_path.tmp" or die "open $full_path.tmp ($!)";
|
||||
for my $file (@{$CSS_APPEND{$css}}) {
|
||||
print " Appending $file\n";
|
||||
my $append_file = HOME . "/static/css/$file";
|
||||
open my $append, "<", $append_file or die "open $append_file: $!";
|
||||
while (<$append>) {
|
||||
print $fh $_;
|
||||
}
|
||||
close $append;
|
||||
}
|
||||
close $fh;
|
||||
}
|
||||
system("java -jar $YUI_COMP $full_path >> $full_path.tmp") or die $!;
|
||||
|
||||
# Minifying breaks this WebKit css filter. Put a space back in between
|
||||
# the 'and' and '('.
|
||||
system("perl -p -i -e 's/\@media screen and\\(/\@media screen and (/' $full_path.tmp");
|
||||
chmod(0644, "$full_path.tmp") or die "chmod $full_path.tmp ($!)";
|
||||
unless (-s "$full_path.tmp") {
|
||||
die "New css file is 0 bytes, bailing!";
|
||||
}
|
||||
rename("$full_path.tmp", $output) or die "rename ($full_path.tmp) ($output): $!";
|
||||
}
|
||||
|
||||
print "\nCreate js files ... \n";
|
||||
for my $js (keys %JS) {
|
||||
print " $js => $JS{$js}\n";
|
||||
my $full_path = HOME . "/static/js/$js";
|
||||
my $output = HOME . "/static/js/$JS{$js}";
|
||||
if (! -e $full_path) {
|
||||
die "Missing js file $full_path";
|
||||
}
|
||||
if ($JS_APPEND{$js}) {
|
||||
open my $fh, ">", "$full_path.tmp" or die "open $full_path.tmp ($!)";
|
||||
for my $file (@{$JS_APPEND{$js}}) {
|
||||
print " Appending $file\n";
|
||||
my $append_file = HOME . "/static/js/$file";
|
||||
open my $append, "<", $append_file or die "open $append_file: $!";
|
||||
while (<$append>) {
|
||||
print $fh $_;
|
||||
}
|
||||
close $append;
|
||||
}
|
||||
close $fh;
|
||||
}
|
||||
system("java -jar $GOOGLE_CLOSURE -js $full_path >> $full_path.tmp");
|
||||
chmod(0644, "$full_path.tmp") or die "chmod $full_path.tmp ($!)";
|
||||
unless (-s "$full_path.tmp") {
|
||||
die "New js file is 0 bytes, bailing!";
|
||||
}
|
||||
rename("$full_path.tmp", $output) or die "rename ($full_path.tmp) ($output): ($!)";
|
||||
}
|
||||
|
||||
my $rev;
|
||||
my $globals = '';
|
||||
open my $fh, "<", HOME . "/templates/include_global_head.html" or die "open include_global_head.html ($!)";
|
||||
while (<$fh>) {
|
||||
if (m{mini_version\s*=\s*'(\d+)'}) {
|
||||
$rev = $1;
|
||||
my $new = $rev + 1;
|
||||
s{mini_version\s*=\s*'(\d+)'}{mini_version = '$new'};
|
||||
$rev = $new;
|
||||
}
|
||||
$globals .= $_;
|
||||
}
|
||||
close $fh;
|
||||
if (! $rev) { die "Couldn't find revision in include_global_head.html"; }
|
||||
|
||||
print "Updating include_global_head.html\n";
|
||||
open $fh, ">", HOME . "/templates/include_global_head.html.new" or die "open: $!";
|
||||
print $fh $globals;
|
||||
close $fh;
|
||||
chmod(0640, HOME . '/templates/include_global_head.html.new') or die "chmod ($!)";
|
||||
rename(HOME . "/templates/include_global_head.html.new", HOME . "/templates/include_global_head.html") or die "rename ($!)";
|
||||
print "Done\n";
|
||||
}
|
||||
23
site/forum.slowtwitch.com/cgi-bin/gforum.cgi
Executable file
23
site/forum.slowtwitch.com/cgi-bin/gforum.cgi
Executable file
@ -0,0 +1,23 @@
|
||||
#!/usr/bin/speedy
|
||||
|
||||
# Nathan moved this to speedycgi, Nov 23 2017 #!/usr/bin/perl
|
||||
|
||||
# ==================================================================
|
||||
# Gossamer Forum - Advanced web community
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: gforum.cgi,v 1.56 2006/03/31 21:32:04 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$PLG/;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
$PLG->dispatch(main => \&GForum::request);
|
||||
6
site/forum.slowtwitch.com/cgi-bin/poll/admin/.htaccess
Normal file
6
site/forum.slowtwitch.com/cgi-bin/poll/admin/.htaccess
Normal file
@ -0,0 +1,6 @@
|
||||
AuthUserFile /home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin/.htpasswd
|
||||
AuthGroupFile /dev/null
|
||||
AuthType Basic
|
||||
AuthName "Gossamer Forum Administration"
|
||||
|
||||
require valid-user
|
||||
411
site/forum.slowtwitch.com/cgi-bin/poll/admin/admin.cgi
Executable file
411
site/forum.slowtwitch.com/cgi-bin/poll/admin/admin.cgi
Executable file
@ -0,0 +1,411 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$DB $CFG $IN/;
|
||||
use vars qw/$PRINT_HEADER $FONT $MAX $poll_vars/;
|
||||
|
||||
local $SIG{__DIE__} = \&GForum::fatal;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
$poll_vars = do "poll.cfg";
|
||||
|
||||
$MAX = 20;
|
||||
$FONT = qq~font face="tacoma, arial, san-serif" size="2"~;
|
||||
main();
|
||||
|
||||
sub main {
|
||||
header();
|
||||
nav();
|
||||
my $do = $IN->param('do');
|
||||
if ($do eq 'add_form') { add_form(); }
|
||||
elsif ($do eq 'add') { add(); }
|
||||
elsif ($do eq 'modify_form') { modify_form(); }
|
||||
elsif ($do eq 'modify') { modify(); }
|
||||
elsif ($do eq 'disable') { disable(); }
|
||||
elsif ($do eq 'enable') { enable(); }
|
||||
elsif ($do eq 'home_show') { home_show(); }
|
||||
elsif ($do eq 'home_notshow') { home_notshow(); }
|
||||
else {
|
||||
&list();
|
||||
}
|
||||
footer();
|
||||
}
|
||||
|
||||
sub header {
|
||||
if (!$PRINT_HEADER) {
|
||||
print $IN->header();
|
||||
}
|
||||
print "<html><head><title>Poll Admin</title></head><body><$FONT>";
|
||||
}
|
||||
|
||||
sub nav {
|
||||
print qq!
|
||||
<b>Poll</b>: <a href="admin.cgi?do=add_form">Add Poll</a> | <a href="admin.cgi">List Poll</a>
|
||||
!;
|
||||
#<br><b>Quiz</b>: <a href="admin.cgi?do=add_form&poll_type=1">Add Quiz</a> | <a href="admin.cgi?poll_type=1">List Quiz</a><br>
|
||||
}
|
||||
|
||||
sub footer {
|
||||
print "</body></html>";
|
||||
}
|
||||
|
||||
sub include_form {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $val = shift || {};
|
||||
my $option = shift || $MAX;
|
||||
my $output = qq~<form action="admin.cgi" method="post">
|
||||
<input type="hidden" name="do" value="$val->{do}">
|
||||
<input type="hidden" name="poll_id" value="$val->{poll_id}">\n~;
|
||||
|
||||
$output .= qq~<p><$FONT color="red">$val->{error}</font></p>~ if $val->{error};
|
||||
|
||||
$output .= qq~
|
||||
<B>Question:</B> <br><textarea rows="4" cols="50" name="poll_question">$val->{poll_question}</textarea><br>\n
|
||||
<B>Description:</B> <br><textarea rows="4" cols="50" name="poll_text">$val->{poll_text}</textarea><br>\n
|
||||
<b>Answers Options:</b> <br>
|
||||
~;
|
||||
my $i = 1;
|
||||
my $select = qq~<select name="poll_answer">~;
|
||||
if ($val->{poll_answers_loop}) {
|
||||
foreach my $ans (@{$val->{poll_answers_loop}}) {
|
||||
$output .= qq~Option $i: <input type="text" name="poll_answer_answer_$i" size="30" value="$ans->{poll_answer_answer}"> ~;
|
||||
if (!$val->{poll_type}) {
|
||||
$output .= qq~Votes: <input type="text" name="poll_answer_votes_$i" size="10" value="$ans->{poll_answer_votes}"><br>\n~;
|
||||
}
|
||||
$output .= qq~<input type="hidden" name="current_poll_answer_id_$i" value="$ans->{poll_answer_id}">\n~;
|
||||
$output .= "<br>";
|
||||
$select .= qq~<option value="$ans->{poll_answer_id}"~;
|
||||
if ($val->{poll_answer} == $ans->{poll_answer_id}) {
|
||||
$select .= " selected";
|
||||
}
|
||||
$select .= qq~>$i</option>\n~;
|
||||
$i++;
|
||||
}
|
||||
if ($IN->param('num_answers') > $i) {
|
||||
foreach ($i .. $IN->param('num_answers')) {
|
||||
$output .= qq~Option $_: <input type="text" name="poll_answer_answer_$_" size="30" value=""> ~;
|
||||
if (!$val->{poll_type}) {
|
||||
$output .= qq~Votes: <input type="text" name="poll_answer_votes_$_" size="10" value="0"><br>\n~;
|
||||
}
|
||||
$output .= "<br>";
|
||||
$select .= qq~<option value="$_">$_</option>\n~;
|
||||
}
|
||||
}
|
||||
$i += 2;
|
||||
}
|
||||
else {
|
||||
foreach (1 .. $option) {
|
||||
my $ans = $val->{'poll_answer_answer_' . $_};
|
||||
$output .= qq~Option $_: <input type="text" name="poll_answer_answer_$_" size="30" value="$ans"> ~;
|
||||
if (!$val->{poll_type}) {
|
||||
$output .= qq~Votes: <input type="text" name="poll_answer_votes_$_" size="10" value="0">\n~;
|
||||
}
|
||||
$output .= "<br>";
|
||||
$select .= qq~<option value="$_">$_</option>\n~;
|
||||
}
|
||||
}
|
||||
$select .= "</select>";
|
||||
if ($val->{poll_type} == 1) {
|
||||
$output .= qq~<b>Right Answer:</b> $select<br><input type="hidden" name="poll_type" value="1">\n~;
|
||||
}
|
||||
$output .= qq~<B>Total Votes:</B> <input type="text" size="10" name="poll_votes" value="$val->{poll_votes}"><br><br>\n~;
|
||||
$output .= $val->{poll_id} ?
|
||||
qq~<input type="submit" value="Modify"> <a href="admin.cgi?do=modify_form&poll_id=$val->{poll_id}&num_answers=$i">Want to add more options?</a></form>~ :
|
||||
qq~<input type="submit" value="Add"></form>~;
|
||||
|
||||
return $output . "\n";
|
||||
}
|
||||
|
||||
sub list {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $msg = shift;
|
||||
my $start_at = $IN->param("start_at") || 1;
|
||||
my $poll_count = $IN->param("poll_count") || 100;
|
||||
my $cgi = $IN->get_hash();
|
||||
$cgi->{nh} ||= $start_at;
|
||||
$cgi->{mh} ||= $poll_count;
|
||||
$cgi->{sb} ||= "poll_date";
|
||||
$cgi->{so} ||= "DESC";
|
||||
$cgi->{poll_type} ||= 0;
|
||||
|
||||
#use Data::Dumper; print "<pre>" . Dumper($cgi) . "</pre>";
|
||||
my $db = $DB->table('Poll');
|
||||
my $ans_db = $DB->table('PollAnswer');
|
||||
my $sth = $db->query_sth($cgi);
|
||||
my $output;
|
||||
|
||||
if ($msg) {
|
||||
$output .= "<p>$msg</p>";
|
||||
}
|
||||
my $i=1;
|
||||
my $correct = "";
|
||||
while (my $row = $sth->fetchrow_hashref()) {
|
||||
my $date = $row->{poll_date};
|
||||
$output .= qq~<p><table width="100%"><tr><td colspan="2"><$FONT>$i.) $row->{poll_question} (posted on $date)</td></tr>
|
||||
<tr><td colspan="2"><$FONT>Description: $row->{poll_text}</td></tr>~;
|
||||
my $answers = $ans_db->select( { poll_id_fk => $row->{poll_id} })->fetchall_hashref();
|
||||
my $max = 0;
|
||||
my $votes = $row->{poll_votes};
|
||||
foreach my $poll_answer (@$answers) {
|
||||
if ($votes) {
|
||||
$poll_answer->{poll_answer_percentage} = sprintf("%" . $poll_vars->{percentage_pre} . "." . $poll_vars->{percentage_post} . "f",$poll_answer->{poll_answer_votes} / $votes * 100);
|
||||
}
|
||||
if ($poll_answer->{poll_answer_votes} > $max) {
|
||||
$max = $poll_answer->{poll_answer_votes};
|
||||
$poll_answer->{poll_answer_is_leading} = 1;
|
||||
}
|
||||
else {
|
||||
$poll_answer->{poll_answer_is_leading} = 0;
|
||||
}
|
||||
if ($poll_answer->{poll_answer_id} == $row->{poll_answer}) {
|
||||
$correct = $poll_answer->{poll_answer_answer};
|
||||
}
|
||||
$output .= qq~
|
||||
<tr>
|
||||
<td align="right" width="20%">
|
||||
<$FONT>
|
||||
$poll_answer->{poll_answer_answer}
|
||||
</td>
|
||||
<td align="left" width="80%">
|
||||
<$FONT> ~;
|
||||
if ($poll_answer->{poll_answer_percentage}) {
|
||||
my $width = $poll_answer->{poll_answer_percentage} * 4;
|
||||
$output .= qq~<img src="/images/leftbar.gif" height="10" width="2" alt="" /><img src="/images/mainbar.gif" height="10" width="$width" alt="" /><img src="/images/rightbar.gif" height="10" width="2" alt="" />~;
|
||||
}
|
||||
else {
|
||||
$output .= qq~<img src="/images/leftbar.gif" height="10" width="2" alt="" /><img src="/images/rightbar.gif" height="10" width="2" alt="" />~;
|
||||
}
|
||||
$output .= qq~$poll_answer->{poll_answer_votes} / $poll_answer->{poll_answer_percentage} %
|
||||
</td>
|
||||
</tr>
|
||||
~;
|
||||
}
|
||||
if ($row->{poll_type}) {
|
||||
$output .= qq~<tr><td colspan="2"><$FONT>The Correct Answer is: $correct</td></tr>~;
|
||||
$output .= qq~<tr><td colspan="2"><$FONT>Total Answered: $row->{poll_votes}</td></tr>~;
|
||||
}
|
||||
else {
|
||||
$output .= qq~<tr><td colspan="2"><$FONT>Total Votes: $row->{poll_votes}</td></tr>~;
|
||||
}
|
||||
$output .= qq~<tr><td colspan="2"><$FONT> <a href="admin.cgi?do=modify_form&poll_id=$row->{poll_id}">Edit</a> | ~;
|
||||
$output .= $row->{poll_enabled} ?
|
||||
qq~<a href="admin.cgi?do=disable&poll_id=$row->{poll_id}"> Disable </a>~ :
|
||||
qq~<a href="admin.cgi?do=enable&poll_id=$row->{poll_id}"> Enable</a>~ ;
|
||||
$output .= $row->{poll_home} ?
|
||||
qq~| <a href="admin.cgi?do=home_notshow&poll_id=$row->{poll_id}"> Don't Show this on Home Page</a>~ :
|
||||
qq~| <a href="admin.cgi?do=home_show&poll_id=$row->{poll_id}"> Show this on Home Page</a>~ ;
|
||||
$output .= qq~</td></tr></table>~;
|
||||
$i++;
|
||||
}
|
||||
print $output;
|
||||
}
|
||||
|
||||
sub add_form {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $cgi = $IN->get_hash();
|
||||
my $error = shift;
|
||||
if ($error) {
|
||||
$cgi->{error} = $error;
|
||||
}
|
||||
$cgi->{do} = 'add';
|
||||
my $form = include_form( { %$cgi }, 4 );
|
||||
print $form;
|
||||
}
|
||||
|
||||
sub add {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
# This subroutine will get called whenever the hook 'do_post_post'
|
||||
# is run.
|
||||
my $total_options = 0;
|
||||
my %seen;
|
||||
my $dup = 0;
|
||||
for (1 .. $MAX) {
|
||||
my $ans = $IN->param("poll_answer_answer_$_");
|
||||
if ($ans) {
|
||||
if ($seen{$ans}) {
|
||||
$dup = 1;
|
||||
last;
|
||||
}
|
||||
$seen{$ans} = 1;
|
||||
$total_options++;
|
||||
}
|
||||
}
|
||||
if ($dup) {
|
||||
return add_form("Answers are the same.");
|
||||
}
|
||||
|
||||
if (!$IN->param('poll_question')) {
|
||||
add_form("No question entered!");
|
||||
return;
|
||||
}
|
||||
if ($total_options < 2) {
|
||||
add_form("POLL_NOT_ENOUGH_OPTIONS");
|
||||
return;
|
||||
}
|
||||
|
||||
# Insert question into Poll table
|
||||
my $a = $DB->table('Poll');
|
||||
my $cgi = $IN->get_hash;
|
||||
$cgi->{'poll_enabled'} = '1';
|
||||
$cgi->{'poll_type'} ||= 0;
|
||||
$cgi->{'poll_votes'} = 0;
|
||||
if (!$cgi->{'poll_type'}){
|
||||
$cgi->{'poll_answer'} = 0;
|
||||
}
|
||||
require GT::Date;
|
||||
$cgi->{'poll_date'} = GT::Date::date_get();
|
||||
my $rec = $a->insert($cgi) or die "$GT::SQL::error";
|
||||
my $poll_id = $rec->insert_id;
|
||||
|
||||
if (!$poll_id) {
|
||||
print "error: can't add poll, reason: $GT::SQL::error";
|
||||
return;
|
||||
}
|
||||
# Insert answers into PollAnswer table
|
||||
my $votes_sum;
|
||||
my $b = $DB->table('PollAnswer');
|
||||
for (my $i = 1; $i <= $MAX; $i++) {
|
||||
my %answer;
|
||||
if ($IN->param("poll_answer_answer_$i")) {
|
||||
$answer{'poll_answer_answer'} = $IN->param("poll_answer_answer_$i");
|
||||
$answer{'poll_answer_votes'} = 0;
|
||||
$answer{'poll_id_fk'} = $poll_id;
|
||||
my $res = $b->insert(\%answer);
|
||||
my $ans_id = $res->insert_id;
|
||||
if ($i == $cgi->{poll_answer}) {
|
||||
$a->update( { poll_answer => $ans_id }, { poll_id => $poll_id });
|
||||
}
|
||||
};
|
||||
};
|
||||
my $msg = "Poll added successfully!";
|
||||
&list($msg);
|
||||
}
|
||||
|
||||
sub modify_form {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $id = $IN->param('poll_id') || shift;
|
||||
if (!$id) {
|
||||
print "no poll id passed";
|
||||
return;
|
||||
}
|
||||
my $poll = $DB->table('Poll')->get($id);
|
||||
my $ans_db = $DB->table('PollAnswer');
|
||||
my $poll_answer = $ans_db->select( { poll_id_fk => $id } )->fetchall_hashref();
|
||||
my $hits = $ans_db->hits;
|
||||
my $form = include_form( { do => 'modify', %$poll, poll_answers_loop => $poll_answer}, 4 );
|
||||
print $form;
|
||||
}
|
||||
|
||||
sub modify {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
# Update existing record or insert new record (PollAnswer table)
|
||||
my $votes_sum = 0;
|
||||
my $a = $DB->table('PollAnswer');
|
||||
for (my $i = 1; $i <= $MAX; $i++) {
|
||||
my %answer;
|
||||
if ($IN->param("poll_answer_answer_$i")) {
|
||||
$answer{'poll_answer_answer'} = $IN->param("poll_answer_answer_$i");
|
||||
if ($IN->param("poll_answer_votes_$i")) {
|
||||
$answer{'poll_answer_votes'} = $IN->param("poll_answer_votes_$i");
|
||||
}
|
||||
$answer{'poll_id_fk'} = $poll_id;
|
||||
$votes_sum += $IN->param("poll_answer_votes_$i");
|
||||
if ($IN->param("current_poll_answer_id_$i")) {
|
||||
$a->update(\%answer, { poll_answer_id => $IN->param("current_poll_answer_id_$i") }) or die $GT::SQL::error;
|
||||
}
|
||||
else {
|
||||
$a->insert(\%answer);
|
||||
}
|
||||
}
|
||||
elsif ($IN->param("current_poll_answer_id_$i") and not $IN->param("poll_answer_answer_$i")) {
|
||||
$a->delete( { poll_answer_id => $IN->param("current_poll_answer_id_$i") });
|
||||
};
|
||||
};
|
||||
|
||||
# Update vote count
|
||||
my $p = $DB->table('Poll');
|
||||
my $poll_type = $IN->param('poll_type') || '0';
|
||||
my $cols = $p->cols;
|
||||
my $mod = {};
|
||||
foreach (keys %$cols) {
|
||||
next if ($_ eq 'poll_id');
|
||||
next if ($_ eq 'poll_date');
|
||||
next if ($_ eq 'poll_home');
|
||||
next if ($_ eq 'poll_enabled');
|
||||
$mod->{$_} = $cgi->{$_};
|
||||
}
|
||||
if (!$poll_type) {
|
||||
$mod->{poll_answer} = 0;
|
||||
$mod->{poll_type} = 0;
|
||||
}
|
||||
$p->update( $mod , { poll_id => $poll_id }) or die "$GT::SQL::error";
|
||||
&list("The poll has been updated successfully!");
|
||||
}
|
||||
|
||||
sub disable {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_enabled => 0 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been disabled.");
|
||||
}
|
||||
|
||||
sub enable {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_enabled => 1 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been enabled.");
|
||||
}
|
||||
|
||||
sub home_show {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_home => 0 });
|
||||
$p->update({ poll_home => 1 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been set to show on home page.");
|
||||
}
|
||||
|
||||
sub home_notshow {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_home => 1 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been removed from showing on the home page.");
|
||||
}
|
||||
83
site/forum.slowtwitch.com/cgi-bin/poll/admin/sql.cgi
Executable file
83
site/forum.slowtwitch.com/cgi-bin/poll/admin/sql.cgi
Executable file
@ -0,0 +1,83 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$DB $CFG/;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
main();
|
||||
|
||||
sub main {
|
||||
# Create the Poll table.
|
||||
my $p = $DB->creator ('Poll');
|
||||
$p->cols([
|
||||
poll_id => { type => 'INT', not_null => 1 },
|
||||
poll_question => { type => 'VARCHAR',size => '255',not_null => 1},
|
||||
poll_answer => { type => 'VARCHAR',size => '255',not_null => 1},
|
||||
poll_type => { type => 'TINYINT',default => '1',not_null => '1'},
|
||||
poll_votes => { type => 'INT',not_null => 1},
|
||||
poll_enabled => { type => 'TINYINT',default => '1',not_null => 1},
|
||||
poll_date => { type => 'Date', not_null => 1},
|
||||
poll_text => { type => 'TEXT', not_null => 0},
|
||||
poll_home => { type => 'TINYINT',default => '0',not_null => 1},
|
||||
]);
|
||||
|
||||
$p->pk('poll_id');
|
||||
$p->ai('poll_id');
|
||||
|
||||
if (!$p->create and $GT::SQL::errcode eq 'TBLEXISTS') {
|
||||
$p->set_defaults();
|
||||
$p->save_schema();
|
||||
}
|
||||
|
||||
# Create the PollAnswer table
|
||||
my $a = $DB->creator ('PollAnswer');
|
||||
$a->cols([
|
||||
poll_answer_id => { type => 'INT', not_null => 1 },
|
||||
poll_id_fk => { type => 'INT', not_null => 1 },
|
||||
poll_answer_answer => {type => 'VARCHAR',size => '255',not_null => 1,default => 0},
|
||||
poll_answer_votes => {type => 'INT',not_null => 1,default => 0}
|
||||
]);
|
||||
|
||||
$a->pk('poll_answer_id');
|
||||
$a->ai('poll_answer_id');
|
||||
|
||||
$a->fk({
|
||||
Poll => { poll_id_fk => 'poll_id' },
|
||||
});
|
||||
|
||||
$a->index({ a_pl => ['poll_id_fk']});
|
||||
|
||||
if (!$a->create and $GT::SQL::errcode eq 'TBLEXISTS') {
|
||||
$a->set_defaults();
|
||||
$a->save_schema();
|
||||
}
|
||||
|
||||
# Create the PollVote table
|
||||
my $v = $DB->creator ('PollVote');
|
||||
$v->cols([
|
||||
poll_vote_id => { type => 'INT', not_null => 1 },
|
||||
poll_id_fk => { type => 'INT', not_null => 1 },
|
||||
poll_vote_ip => { type => 'VARCHAR',size => '15', not_null => 1 },
|
||||
poll_vote_time => { type => 'INT', default => '0', not_null => '1' }
|
||||
]);
|
||||
|
||||
$v->pk('poll_vote_id');
|
||||
$v->ai('poll_vote_id');
|
||||
|
||||
$v->fk ( {
|
||||
'Poll' => {
|
||||
'poll_id_fk' => 'poll_id'
|
||||
},
|
||||
});
|
||||
|
||||
$v->index({ v_p => ['poll_id_fk'] });
|
||||
|
||||
if (!$v->create and $GT::SQL::errcode eq 'TBLEXISTS') {
|
||||
$v->set_defaults();
|
||||
$v->save_schema();
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
11
site/forum.slowtwitch.com/cgi-bin/poll/poll.cgi
Executable file
11
site/forum.slowtwitch.com/cgi-bin/poll/poll.cgi
Executable file
@ -0,0 +1,11 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$DB $CFG $IN/;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
use Poll;
|
||||
Poll::handle();
|
||||
|
||||
107
site/forum.slowtwitch.com/cgi-bin/silent_post_live.cgi
Executable file
107
site/forum.slowtwitch.com/cgi-bin/silent_post_live.cgi
Executable file
@ -0,0 +1,107 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/:objects/;
|
||||
use GForum::Payment qw/:status :log/;
|
||||
use Data::Dumper;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
use GT::Payment::Direct::AuthorizeDotNetRec;
|
||||
use Slowtwitch::Payment;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
main();
|
||||
|
||||
sub main {
|
||||
silent_post();
|
||||
}
|
||||
|
||||
sub silent_post {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handle PayPal postback
|
||||
my $unique = $IN->param('x_invoice_num');
|
||||
my $pay = $DB->table('Subscription_Payments');
|
||||
my $log = $DB->table('Subscription_PaymentLogs');
|
||||
my $in = $IN->get_hash();
|
||||
my $payment = $pay->get($unique);
|
||||
if (!$payment) {
|
||||
open (LOG, ">>/var/home/virginia/virginialo.com/cgi-bin/forum/admin/auth_silent_error.log");
|
||||
print LOG Dumper($in);
|
||||
close (LOG);
|
||||
print $IN->header . "No such invoice: $unique.";
|
||||
return;
|
||||
}
|
||||
|
||||
open (LOG, ">>/var/home/virginia/virginialo.com/cgi-bin/forum/admin/auth_silent_live.log");
|
||||
print LOG Dumper($payment,$in);
|
||||
close (LOG);
|
||||
|
||||
print $IN->header;
|
||||
GT::Payment::Direct::AuthorizeDotNetRec::process(
|
||||
param => $IN,
|
||||
test_mode => $CFG->{payment}->{direct}->{used}->{AuthorizeDotNetRec}->{test_mode},
|
||||
account_username => $CFG->{payment}->{direct}->{used}->{AuthorizeDotNetRec}->{account_username},
|
||||
md5_key => $CFG->{payment}->{direct}->{used}->{AuthorizeDotNetRec}->{md5_key},
|
||||
duplicate => sub {
|
||||
my $id = $IN->param('x_trans_id');
|
||||
my $cond = GT::SQL::Condition->new();
|
||||
$cond->add(paylogs_payments_id => '=' => $unique);
|
||||
$cond->add(paylogs_type => '=' => LOG_ACCEPTED);
|
||||
$cond->add(paylogs_text => LIKE => "%Transaction ID: $id\n%");
|
||||
my $found = $log->count($cond);
|
||||
#warn "$found ($id) **";
|
||||
return $found ? undef : 1; # True if everything checks out; undef if a duplicate was found
|
||||
},
|
||||
on_invalid => sub {
|
||||
},
|
||||
on_error => sub {
|
||||
my $errmsg = shift;
|
||||
print $errmsg . "\n";
|
||||
$pay->update(
|
||||
{ payments_status => ERROR, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => $errmsg
|
||||
});
|
||||
},
|
||||
on_recurring => sub {
|
||||
if ($IN->param('x_amount') < $payment->{payments_amount}) {
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Invalid payment (payment amount is less than original charge): " .
|
||||
$IN->param('x_amount') . " < " . $payment->{payments_amount}
|
||||
});
|
||||
return;
|
||||
}
|
||||
|
||||
$pay->update(
|
||||
{ payments_status => COMPLETED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ACCEPTED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
"Transaction ID: " . $IN->param('x_trans_id') . "\n" .
|
||||
"Amount: " . $IN->param('x_amount') . " " .
|
||||
"Subscription payment #: " . $IN->param('x_subscription_paynum') . " " .
|
||||
"Subscription ID: " . $IN->param('x_subscription_id') . "\n"
|
||||
)
|
||||
});
|
||||
|
||||
Slowtwitch::Payment::process_payment($payment->{payments_userid}, '', $payment->{payments_id});
|
||||
}
|
||||
);
|
||||
|
||||
1;
|
||||
}
|
||||
24
site/forum.slowtwitch.com/cgi-bin/threads.cgi
Executable file
24
site/forum.slowtwitch.com/cgi-bin/threads.cgi
Executable file
@ -0,0 +1,24 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib "/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin";
|
||||
use GForum qw/$IN $CFG $DB/;
|
||||
use GForum::SEO;
|
||||
|
||||
GForum::init("/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin");
|
||||
|
||||
my @ids = split(/\s*,\s*/, $IN->param('id') || '');
|
||||
|
||||
print $IN->header;
|
||||
if (scalar @ids) {
|
||||
my $posts = $DB->table('Post')->select(/post_id post_subject/, { post_id => \@ids })->fetchall_hashref;
|
||||
my %posts = map { $_->{post_id} => $_ } @$posts;
|
||||
|
||||
my ($count, $html) = (0, "");
|
||||
foreach my $id (@ids) {
|
||||
$count++;
|
||||
my $url = $CFG->{cgi_root_url} . GForum::SEO::url(type => "post", id => $id);
|
||||
$html .= qq!<div class="link"><div><span>$count</span></div><a href="$url">$posts{$id}{post_subject}</a></div>!;
|
||||
}
|
||||
print qq!<div class="list">$html</div>!;
|
||||
}
|
||||
6
site/forum.slowtwitch.com/cgi-bin/ticker/admin/.htaccess
Normal file
6
site/forum.slowtwitch.com/cgi-bin/ticker/admin/.htaccess
Normal file
@ -0,0 +1,6 @@
|
||||
AuthUserFile /home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin/.htpasswd
|
||||
AuthGroupFile /dev/null
|
||||
AuthType Basic
|
||||
AuthName "Gossamer Forum Administration"
|
||||
|
||||
require valid-user
|
||||
160
site/forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi
Executable file
160
site/forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi
Executable file
@ -0,0 +1,160 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# The ticker (client & admin) loosely follows an MVC architecture. The model
|
||||
# is over in Ticker.pm (it does all the DB work). ticker.cgi is the view for
|
||||
# the client, while this is the view+controller for the admin.
|
||||
#
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
use Error qw(:try);
|
||||
|
||||
use constant {
|
||||
STATE_NORMAL => 0,
|
||||
STATE_UPDATE => 1,
|
||||
STATE_REDIRECT => 2,
|
||||
ADMIN_URL => "http://forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi"
|
||||
};
|
||||
|
||||
# prototypes.
|
||||
sub controller();
|
||||
sub view($);
|
||||
|
||||
# And call the controller.
|
||||
controller();
|
||||
|
||||
#
|
||||
# This is the controller. This is where work gets done.
|
||||
#
|
||||
sub controller() {
|
||||
my %viewstate = (state => STATE_NORMAL);
|
||||
|
||||
# if we have an action parameter (that's non-empty), then do work:
|
||||
if(defined $IN->param('action') && length($IN->param('action')) > 0) {
|
||||
$viewstate{state} = STATE_REDIRECT;
|
||||
try {
|
||||
my $p = $IN->get_hash();
|
||||
if($p->{action} =~ /create/) {
|
||||
Ticker::create_ticker($p->{msg}, $p->{link});
|
||||
} elsif($p->{action} =~ /show_update/) {
|
||||
$viewstate{state} = STATE_UPDATE;
|
||||
$viewstate{id} = $p->{'id'};
|
||||
} elsif($p->{action} =~ /do_update/) {
|
||||
Ticker::update_ticker($p->{'id'}, $p->{'msg'}, $p->{'link'});
|
||||
} elsif($p->{action} =~ /delete/) {
|
||||
Ticker::delete_ticker($p->{'id'});
|
||||
}
|
||||
} catch Ticker::TickerException with {
|
||||
# oops. something bad happened.
|
||||
$viewstate{error} = "Error: " . shift;
|
||||
# reset the viewstate so that we display the error message.
|
||||
$viewstate{state} = STATE_NORMAL;
|
||||
};
|
||||
}
|
||||
|
||||
return view(\%viewstate);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Build the view, which takes a single hashref describing how the view should
|
||||
# behave.
|
||||
#
|
||||
sub view($) {
|
||||
my ($state) = @_;
|
||||
my %s = %$state;
|
||||
|
||||
# If the state is redirect, we're done.
|
||||
if($s{state} == STATE_REDIRECT) {
|
||||
print $IN->redirect(ADMIN_URL);
|
||||
return;
|
||||
}
|
||||
|
||||
# Now let's actually build the view, depending on our current state:
|
||||
print $IN->header();
|
||||
print qq{<html><head><title>Ticker Admin</title></head><body>};
|
||||
|
||||
# Try to load all the tickers:
|
||||
try {
|
||||
$s{data} = Ticker::read_tickers();
|
||||
|
||||
# Are we also trying to update a record? Yeah, I know - we're
|
||||
# hitting the db again. I wish that fetchall_hashref actually worked...
|
||||
if(defined $s{id}) {
|
||||
my $result = Ticker::read_ticker($s{id});
|
||||
$s{msg} = $result->{ticker_text};
|
||||
$s{link} = $result->{ticker_link};
|
||||
}
|
||||
} catch Ticker::TickerException with {
|
||||
$s{error} .= " Could not read tickers from database!";
|
||||
};
|
||||
|
||||
# Print an error message if we have one:
|
||||
if(defined $s{error}) {
|
||||
print "<p>" . $s{error} . "</p>";
|
||||
}
|
||||
|
||||
# What should the top form look like?
|
||||
if($s{state} == STATE_NORMAL) {
|
||||
$s{title} = 'Create a ticker:';
|
||||
$s{submit} = 'Create ticker';
|
||||
$s{action} = 'create';
|
||||
$s{id} = "";
|
||||
$s{msg} = "";
|
||||
$s{link} = "";
|
||||
} elsif($s{state} == STATE_UPDATE) {
|
||||
$s{title} = 'Update a ticker:';
|
||||
$s{submit} = 'Update ticker';
|
||||
$s{action} = 'do_update';
|
||||
}
|
||||
|
||||
# print the form, which is configured for the type of action we're
|
||||
# performing:
|
||||
print qq{<h3>} . $s{title} . qq{</h3>
|
||||
<form method="post" action="} . ADMIN_URL . qq{">
|
||||
<input type="hidden" name="action" value="} .
|
||||
$s{action} . qq{"/>
|
||||
<input type="hidden" name="id" value="} . $s{id} . qq{"/>
|
||||
<div><label for="message">Message:</label>
|
||||
<input type="text" name="msg" value="} . $s{msg} . qq{"/>
|
||||
</div><div><label for="link">Link:</label>
|
||||
<input type="text" name="link" value="} . $s{link} . qq{"/>
|
||||
</div><div><input type="submit" value="} . $s{submit} . qq{"/>
|
||||
</div></form>
|
||||
};
|
||||
|
||||
# provide a way to get back to the create interface:
|
||||
if($s{action} =~ /update/) {
|
||||
print qq{<a href="} . ADMIN_URL . qq{">Create a ticker instead.</a>};
|
||||
}
|
||||
|
||||
# Now print the entire list of all tickers.
|
||||
print qq{<h3>Current tickers:</h3>};
|
||||
|
||||
|
||||
# If there are no tickers, say so:
|
||||
if(@{$s{data}} == 0) {
|
||||
print "There are no tickers.";
|
||||
} else {
|
||||
# Print a table showing the ID, delete/edit links, messages, and links:
|
||||
print "<table>";
|
||||
print "<tr><td>ID</td><td/><td/><td>Message</td><td>Link</td></tr>";
|
||||
foreach my $k (@{$s{data}}) {
|
||||
my $id = $k->{ticker_id};
|
||||
my $msg = $k->{ticker_text};
|
||||
my $link = $k->{ticker_link};
|
||||
print qq{<tr><td>$id</td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=delete&id=$id">Delete</a></td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=show_update&id=$id">Update</a></td><td>} .
|
||||
$msg . "</td><td>" .
|
||||
qq{<a href="} . $link . qq{">} .
|
||||
$link . "</a></td></tr>";
|
||||
}
|
||||
print "</table>";
|
||||
}
|
||||
print qq{</body></html>};
|
||||
}
|
||||
|
||||
8
site/forum.slowtwitch.com/cgi-bin/ticker/admin/sql.cgi
Executable file
8
site/forum.slowtwitch.com/cgi-bin/ticker/admin/sql.cgi
Executable file
@ -0,0 +1,8 @@
|
||||
#!/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use Ticker;
|
||||
|
||||
Ticker::create_table();
|
||||
18
site/forum.slowtwitch.com/cgi-bin/ticker/coupons.cgi
Executable file
18
site/forum.slowtwitch.com/cgi-bin/ticker/coupons.cgi
Executable file
@ -0,0 +1,18 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header();
|
||||
GForum::Template->parse_print('include_ticker_coupons.html');
|
||||
|
||||
17
site/forum.slowtwitch.com/cgi-bin/ticker/ticker.cgi
Executable file
17
site/forum.slowtwitch.com/cgi-bin/ticker/ticker.cgi
Executable file
@ -0,0 +1,17 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header(-type => "text/xml");
|
||||
print Ticker::read_tickers_xml();
|
||||
@ -0,0 +1,6 @@
|
||||
AuthUserFile /home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin/.htpasswd
|
||||
AuthGroupFile /dev/null
|
||||
AuthType Basic
|
||||
AuthName "Gossamer Forum Administration"
|
||||
|
||||
require valid-user
|
||||
160
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi
Executable file
160
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi
Executable file
@ -0,0 +1,160 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# The ticker (client & admin) loosely follows an MVC architecture. The model
|
||||
# is over in TickerAd.pm (it does all the DB work). ticker.cgi is the view for
|
||||
# the client, while this is the view+controller for the admin.
|
||||
#
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use TickerAd;
|
||||
use Error qw(:try);
|
||||
|
||||
use constant {
|
||||
STATE_NORMAL => 0,
|
||||
STATE_UPDATE => 1,
|
||||
STATE_REDIRECT => 2,
|
||||
ADMIN_URL => "http://forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi"
|
||||
};
|
||||
|
||||
# prototypes.
|
||||
sub controller();
|
||||
sub view($);
|
||||
|
||||
# And call the controller.
|
||||
controller();
|
||||
|
||||
#
|
||||
# This is the controller. This is where work gets done.
|
||||
#
|
||||
sub controller() {
|
||||
my %viewstate = (state => STATE_NORMAL);
|
||||
|
||||
# if we have an action parameter (that's non-empty), then do work:
|
||||
if(defined $IN->param('action') && length($IN->param('action')) > 0) {
|
||||
$viewstate{state} = STATE_REDIRECT;
|
||||
try {
|
||||
my $p = $IN->get_hash();
|
||||
if($p->{action} =~ /create/) {
|
||||
TickerAd::create_ticker($p->{msg}, $p->{link});
|
||||
} elsif($p->{action} =~ /show_update/) {
|
||||
$viewstate{state} = STATE_UPDATE;
|
||||
$viewstate{id} = $p->{'id'};
|
||||
} elsif($p->{action} =~ /do_update/) {
|
||||
TickerAd::update_ticker($p->{'id'}, $p->{'msg'}, $p->{'link'});
|
||||
} elsif($p->{action} =~ /delete/) {
|
||||
TickerAd::delete_ticker($p->{'id'});
|
||||
}
|
||||
} catch TickerAd::TickerAdException with {
|
||||
# oops. something bad happened.
|
||||
$viewstate{error} = "Error: " . shift;
|
||||
# reset the viewstate so that we display the error message.
|
||||
$viewstate{state} = STATE_NORMAL;
|
||||
};
|
||||
}
|
||||
|
||||
return view(\%viewstate);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Build the view, which takes a single hashref describing how the view should
|
||||
# behave.
|
||||
#
|
||||
sub view($) {
|
||||
my ($state) = @_;
|
||||
my %s = %$state;
|
||||
|
||||
# If the state is redirect, we're done.
|
||||
if($s{state} == STATE_REDIRECT) {
|
||||
print $IN->redirect(ADMIN_URL);
|
||||
return;
|
||||
}
|
||||
|
||||
# Now let's actually build the view, depending on our current state:
|
||||
print $IN->header();
|
||||
print qq{<html><head><title>TickerAd Admin</title></head><body>};
|
||||
|
||||
# Try to load all the tickers:
|
||||
try {
|
||||
$s{data} = TickerAd::read_tickers();
|
||||
|
||||
# Are we also trying to update a record? Yeah, I know - we're
|
||||
# hitting the db again. I wish that fetchall_hashref actually worked...
|
||||
if(defined $s{id}) {
|
||||
my $result = TickerAd::read_ticker($s{id});
|
||||
$s{msg} = $result->{ticker_text};
|
||||
$s{link} = $result->{ticker_link};
|
||||
}
|
||||
} catch TickerAd::TickerAdException with {
|
||||
$s{error} .= " Could not read tickers from database!";
|
||||
};
|
||||
|
||||
# Print an error message if we have one:
|
||||
if(defined $s{error}) {
|
||||
print "<p>" . $s{error} . "</p>";
|
||||
}
|
||||
|
||||
# What should the top form look like?
|
||||
if($s{state} == STATE_NORMAL) {
|
||||
$s{title} = 'Create a ticker:';
|
||||
$s{submit} = 'Create ticker';
|
||||
$s{action} = 'create';
|
||||
$s{id} = "";
|
||||
$s{msg} = "";
|
||||
$s{link} = "";
|
||||
} elsif($s{state} == STATE_UPDATE) {
|
||||
$s{title} = 'Update a ticker:';
|
||||
$s{submit} = 'Update ticker';
|
||||
$s{action} = 'do_update';
|
||||
}
|
||||
|
||||
# print the form, which is configured for the type of action we're
|
||||
# performing:
|
||||
print qq{<h3>} . $s{title} . qq{</h3>
|
||||
<form method="post" action="} . ADMIN_URL . qq{">
|
||||
<input type="hidden" name="action" value="} .
|
||||
$s{action} . qq{"/>
|
||||
<input type="hidden" name="id" value="} . $s{id} . qq{"/>
|
||||
<div><label for="message">Message:</label>
|
||||
<input type="text" name="msg" value="} . $s{msg} . qq{"/>
|
||||
</div><div><label for="link">Link:</label>
|
||||
<input type="text" name="link" value="} . $s{link} . qq{"/>
|
||||
</div><div><input type="submit" value="} . $s{submit} . qq{"/>
|
||||
</div></form>
|
||||
};
|
||||
|
||||
# provide a way to get back to the create interface:
|
||||
if($s{action} =~ /update/) {
|
||||
print qq{<a href="} . ADMIN_URL . qq{">Create a ticker instead.</a>};
|
||||
}
|
||||
|
||||
# Now print the entire list of all tickers.
|
||||
print qq{<h3>Current tickers:</h3>};
|
||||
|
||||
|
||||
# If there are no tickers, say so:
|
||||
if(@{$s{data}} == 0) {
|
||||
print "There are no tickers.";
|
||||
} else {
|
||||
# Print a table showing the ID, delete/edit links, messages, and links:
|
||||
print "<table>";
|
||||
print "<tr><td>ID</td><td/><td/><td>Message</td><td>Link</td></tr>";
|
||||
foreach my $k (@{$s{data}}) {
|
||||
my $id = $k->{ticker_id};
|
||||
my $msg = $k->{ticker_text};
|
||||
my $link = $k->{ticker_link};
|
||||
print qq{<tr><td>$id</td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=delete&id=$id">Delete</a></td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=show_update&id=$id">Update</a></td><td>} .
|
||||
$msg . "</td><td>" .
|
||||
qq{<a href="} . $link . qq{">} .
|
||||
$link . "</a></td></tr>";
|
||||
}
|
||||
print "</table>";
|
||||
}
|
||||
print qq{</body></html>};
|
||||
}
|
||||
|
||||
8
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/sql.cgi
Executable file
8
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/sql.cgi
Executable file
@ -0,0 +1,8 @@
|
||||
#!/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use Ticker;
|
||||
|
||||
Ticker::create_table();
|
||||
18
site/forum.slowtwitch.com/cgi-bin/tickerad/coupons.cgi
Executable file
18
site/forum.slowtwitch.com/cgi-bin/tickerad/coupons.cgi
Executable file
@ -0,0 +1,18 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header();
|
||||
GForum::Template->parse_print('include_ticker_coupons.html');
|
||||
|
||||
17
site/forum.slowtwitch.com/cgi-bin/tickerad/ticker.cgi
Executable file
17
site/forum.slowtwitch.com/cgi-bin/tickerad/ticker.cgi
Executable file
@ -0,0 +1,17 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header(-type => "text/xml");
|
||||
print Ticker::read_tickers_xml();
|
||||
89
site/forum.slowtwitch.com/cgi-bin/toggle.cgi
Executable file
89
site/forum.slowtwitch.com/cgi-bin/toggle.cgi
Executable file
@ -0,0 +1,89 @@
|
||||
#!/usr/bin/perl
|
||||
# ==================================================================
|
||||
# Gossamer Forum -
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: gforum.cgi,v 1.52.2.5 2003/10/10 20:30:01 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/:forum :user $DB $IN $CFG $USER $GUEST %HIDDEN $TEMPLATE_SET/;
|
||||
use GForum::Template;
|
||||
use GForum::Authenticate;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
main();
|
||||
|
||||
sub main {
|
||||
# -------------------------------------------------------------------
|
||||
# Display whatever page the user has requested
|
||||
#
|
||||
local $SIG{__DIE__} = \&GForum::fatal;
|
||||
|
||||
# Show the disabled page if the forum has been disabled
|
||||
if ($CFG->{disabled} == 1) {
|
||||
print $IN->header;
|
||||
my $message = $CFG->{disabled_message};
|
||||
$message =~ s/\n/<br>\n/g;
|
||||
return GForum::Template->parse_print("disabled.html" => { message => \$message });
|
||||
}
|
||||
{
|
||||
# If the user is banned, simply deny them access
|
||||
my @expanded_bans = @{$CFG->{bans}};
|
||||
for (@expanded_bans) {
|
||||
if (/^(\d+\.\d+\.\d+\.)(\d+)-(\d+)$/ and $2 < $3) {
|
||||
# Allows you to specify '123.45.67.89-123' to ban that range of IP's
|
||||
for ($2 .. $3) {
|
||||
push @expanded_bans, "$1$_";
|
||||
}
|
||||
next;
|
||||
}
|
||||
# Turn a ban into a regexp
|
||||
my $ban = quotemeta($_);
|
||||
# *'s match anything
|
||||
$ban =~ s/\\\*/.*/g;
|
||||
# ?'s match any single character
|
||||
$ban =~ s/\\\?/./g;
|
||||
if ($ENV{REMOTE_HOST} and $ENV{REMOTE_HOST} =~ /^$ban$/i or $ENV{REMOTE_ADDR} =~ /^$ban$/i) {
|
||||
print $IN->header;
|
||||
return GForum::Template->parse_print($CFG->{functions}->{banned}->{page}, { error => GForum::language('USER_BANNED') });
|
||||
}
|
||||
}
|
||||
}
|
||||
GForum::authenticate() or return; # False = stop!
|
||||
|
||||
if ($CFG->{disabled} == 2 and (not $USER or $USER->{user_status} != ADMINISTRATOR)) {
|
||||
print $IN->header;
|
||||
my $message = $CFG->{disabled_message};
|
||||
$message =~ s/\n/<br>\n/g;
|
||||
return GForum::Template->parse_print("disabled.html" => { message => \$message });
|
||||
}
|
||||
|
||||
my $template_set = $IN->param('t');
|
||||
if (not $template_set or $template_set !~ /^[\w-]+$/ or not -d "$CFG->{admin_root_path}/templates/$template_set" or $template_set =~ /^(?:help|admin|fileman|CVS)$/) {
|
||||
$template_set = '';
|
||||
}
|
||||
else { # It's good!
|
||||
$HIDDEN{t} = $template_set;
|
||||
}
|
||||
|
||||
if ($USER) {
|
||||
if ($USER->{user_show_racetags}) {
|
||||
$DB->table('User')->update({ user_show_racetags => 0 }, { user_id => $USER->{user_id} });
|
||||
print $IN->header . qq~Hidden <a href="#" onclick="return status_toggle()">(click to unhide)</a>~;
|
||||
}
|
||||
else {
|
||||
$DB->table('User')->update({ user_show_racetags => 1 }, { user_id => $USER->{user_id} });
|
||||
print $IN->header . qq~Viewable <a href="#" onclick="return status_toggle()">(click to hide)</a>~;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
27
site/forum.slowtwitch.com/cgi-bin/widget.cgi
Executable file
27
site/forum.slowtwitch.com/cgi-bin/widget.cgi
Executable file
@ -0,0 +1,27 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin';
|
||||
|
||||
use Links qw/$PLG $IN $DB/;
|
||||
use Links::User::Page;
|
||||
|
||||
local $SIG{__DIE__} = \&Links::fatal;
|
||||
|
||||
Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin');
|
||||
|
||||
my $id = $IN->param('id');
|
||||
|
||||
print $IN->header;
|
||||
if ($id) {
|
||||
my $tab = $DB->table('Widgets');
|
||||
my $widget = $tab->get($id);
|
||||
|
||||
if ($widget) {
|
||||
if ($widget->{Image}) {
|
||||
my $fh = $tab->file_info('Image', $widget->{ID});
|
||||
$widget->{Image_URL} = '/images/widgets/' . $fh->File_RelativeURL;
|
||||
}
|
||||
print Links::SiteHTML::display('include_widgets', { widgets_loop => [$widget] });
|
||||
}
|
||||
}
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 7.7 KiB |
1251
site/glist/lib/GList.pm
Normal file
1251
site/glist/lib/GList.pm
Normal file
File diff suppressed because it is too large
Load Diff
1344
site/glist/lib/GList/Admin.pm
Normal file
1344
site/glist/lib/GList/Admin.pm
Normal file
File diff suppressed because it is too large
Load Diff
246
site/glist/lib/GList/Authenticate.pm
Normal file
246
site/glist/lib/GList/Authenticate.pm
Normal file
@ -0,0 +1,246 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Authenticate.pm,v 1.15 2004/04/15 19:46:36 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::Authenticate;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects/;
|
||||
use GT::Session::SQL;
|
||||
|
||||
sub auth {
|
||||
# -------------------------------------------------------------------
|
||||
# Runs the request auth function through the plugin system.
|
||||
#
|
||||
($_[0] eq 'GList::Authenticate') and shift;
|
||||
|
||||
my ($auth, $args) = @_;
|
||||
my $code = exists $GList::Authenticate::{"auth_$auth"} ? $GList::Authenticate::{"auth_$auth"} : die "Invalid Authenticate method: auth_$auth called.";
|
||||
GT::Plugins->dispatch("$CFG->{priv_path}/lib/GList/Plugins", "auth_$auth", $code, $args);
|
||||
}
|
||||
|
||||
sub auth_init {
|
||||
# -------------------------------------------------------------------
|
||||
# This function is guaranteed to be called before any other authentication
|
||||
# function, but may be called multiple times during one request.
|
||||
#
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_get_user {
|
||||
# -------------------------------------------------------------------
|
||||
# This function returns user information for a given user, auto
|
||||
# creating if it doesn't exist.
|
||||
#
|
||||
my $args = shift;
|
||||
return $DB->table ('Users')->get({ usr_username => $args->{username}, usr_status => '1' });
|
||||
}
|
||||
|
||||
sub auth_valid_user {
|
||||
# -------------------------------------------------------------------
|
||||
# This function returns 1 if the user/pass combo is valid, 0/undef
|
||||
# otherwise.
|
||||
#
|
||||
my $args = shift;
|
||||
my $user = $DB->table('Users')->get($args->{username});
|
||||
return if ( !$user );
|
||||
|
||||
return ($user->{usr_password} eq GList::encrypt($args->{password}, $user->{usr_password})) ? 1 : 0;
|
||||
}
|
||||
|
||||
sub auth_create_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This function creates a session, and prints the header and returns a
|
||||
# hash with session => $id, and redirect => 0/1.
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
my $uid = $args->{username};
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
my $session = GT::Session::SQL->new ({
|
||||
_debug => $CFG->{debug},
|
||||
tb => $DB->table('Users_Sessions'),
|
||||
session_user_id => $uid,
|
||||
session_data => { cookie => $use_cookie, do => scalar($IN->param('do')) },
|
||||
expires => $CFG->{session_exp},
|
||||
}
|
||||
);
|
||||
|
||||
if ( $GT::Session::SQL::error ) {
|
||||
return { error => $GT::Session::SQL::error };
|
||||
}
|
||||
# Delete all old sessions.
|
||||
$session->cleanup;
|
||||
if ($use_cookie) {
|
||||
print $IN->cookie(
|
||||
-name => 'sid',
|
||||
-value => $session->{info}->{session_id},
|
||||
)->cookie_header() . "\n";
|
||||
}
|
||||
return { session_id => $session->{info}->{session_id}, use_cookie => $use_cookie };
|
||||
}
|
||||
|
||||
sub auth_valid_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This functions checks to see if the session is valid, and returns the
|
||||
# username.
|
||||
my $args = shift;
|
||||
my ($sid, $cookie);
|
||||
if ($IN->param ('sid')) {
|
||||
$sid = $IN->param ('sid');
|
||||
}
|
||||
elsif ( !$CFG->{user_session} and $IN->cookie ('sid') ) {
|
||||
$cookie = 1;
|
||||
$sid = $IN->cookie ('sid');
|
||||
}
|
||||
else { return }
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
|
||||
# Cookie authentication
|
||||
my $session = new GT::Session::SQL ({
|
||||
_debug => $CFG->{debug},
|
||||
tb => $DB->table('Users_Sessions'),
|
||||
session_id => $sid,
|
||||
expires => $CFG->{session_exp},
|
||||
session_data => { cookie => $use_cookie, do => scalar($IN->param('do')) },
|
||||
}) or return;
|
||||
|
||||
# Delete any of the user's expired sessions
|
||||
$sid = '' if ($session->{data}->{cookie});
|
||||
|
||||
# Must return the session id and the userid
|
||||
return { session_id => $session->{info}->{session_id}, use_cookie => $use_cookie, user_name => $session->{info}->{session_user_id} };
|
||||
}
|
||||
|
||||
sub auth_delete_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This function removes a session, returns 1 on success, undef on
|
||||
# failure.
|
||||
#
|
||||
my $args = shift;
|
||||
my $sid;
|
||||
if ( $IN->param('sid') ) {
|
||||
$sid = $IN->param ('sid');
|
||||
}
|
||||
elsif ( !$CFG->{user_session} and $IN->cookie('sid') ) {
|
||||
$sid = $IN->cookie ('sid');
|
||||
}
|
||||
else { return }
|
||||
|
||||
my $session = new GT::Session::SQL (
|
||||
{
|
||||
_debug => $CFG->{debug},
|
||||
tb => $DB->table ('Users_Sessions'),
|
||||
session_id => $sid
|
||||
}
|
||||
) or return;
|
||||
|
||||
# Delete the cookie
|
||||
$session->delete or return;
|
||||
|
||||
# Print the cookie header
|
||||
if (!$CFG->{user_session}) {
|
||||
print $IN->cookie(
|
||||
-name => 'sid',
|
||||
-value => $sid,
|
||||
-expires => '-1h'
|
||||
)->cookie_header() . "\n";
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_admin_valid_user {
|
||||
#---------------------------------------------------------
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
my $admins = $CFG->{admin};
|
||||
foreach my $u (keys % $admins) {
|
||||
my $pass = $admins->{$u}->[0];
|
||||
if ($u eq $args->{username} and GList::encrypt($args->{password}, $pass) eq $pass ) {
|
||||
return $args->{username};
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub auth_admin_create_session {
|
||||
#---------------------------------------------------------
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
# Clear out old sessions.
|
||||
require GT::Session::File;
|
||||
GT::Session::File->cleanup(1800, "$CFG->{priv_path}/tmp");
|
||||
|
||||
# Create a new session and save the information.
|
||||
my $session = new GT::Session::File ( directory => "$CFG->{priv_path}/tmp" );
|
||||
$session->{data}->{username} = $args->{username};
|
||||
my $session_id = $session->{id};
|
||||
$session->save;
|
||||
|
||||
# Now redirect to another URL and set cookies, or set URL string.
|
||||
my $redirect = 0;
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
if ($use_cookie) {
|
||||
print $IN->cookie (
|
||||
-name => 'session_id',
|
||||
-value => $session_id,
|
||||
-path => '/'
|
||||
)->cookie_header() . "\n";
|
||||
}
|
||||
return { session_id => $session_id, use_cookie => $use_cookie };
|
||||
}
|
||||
|
||||
sub auth_admin_valid_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This functions checks to see if the session is valid, and returns the
|
||||
# username.
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
# Clear out old sessions.
|
||||
require GT::Session::File;
|
||||
GT::Session::File->cleanup(1800, "$CFG->{priv_path}/tmp");
|
||||
|
||||
my $session_id = $IN->param('session_id') || $IN->cookie('session_id') || return;
|
||||
my $session = new GT::Session::File (
|
||||
directory => "$CFG->{priv_path}/tmp",
|
||||
id => $session_id
|
||||
) || return;
|
||||
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
return { username => $session->{data}->{username}, session_id => $session_id, use_cookie => $use_cookie };
|
||||
}
|
||||
|
||||
sub auth_admin_delete_session {
|
||||
#--------------------------------------------------------
|
||||
#
|
||||
require GT::Session::File;
|
||||
my $session_id = $IN->cookie('session_id') || $IN->param('session_id') || return;
|
||||
my $session = new GT::Session::File(
|
||||
directory => "$CFG->{priv_path}/tmp",
|
||||
id => $session_id
|
||||
) || return;
|
||||
|
||||
print $IN->cookie(
|
||||
-name => 'session_id',
|
||||
-value => '',
|
||||
-path => '/'
|
||||
)->cookie_header() . "\n";
|
||||
|
||||
return $session->delete();
|
||||
}
|
||||
|
||||
1;
|
||||
196
site/glist/lib/GList/Config.pm
Normal file
196
site/glist/lib/GList/Config.pm
Normal file
@ -0,0 +1,196 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Config.pm,v 1.7 2004/10/05 22:02:27 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::Config;
|
||||
# =============================================================================
|
||||
# Sets up our config variables -- if you are looking to hand edit variables the
|
||||
# data is in GList/Config/Data.pm, but you shouldn't have to do this, really!
|
||||
#
|
||||
use GT::Config();
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::Config';
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $class = ref $_[0] ? ref shift : shift;
|
||||
my $path = shift || '.';
|
||||
|
||||
my $file = "$path/GList/Config/Data.pm";
|
||||
|
||||
my $self = $class->load($file => {
|
||||
debug => $GList::DEBUG,
|
||||
header => <<'HEADER'
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website: http://gossamer-threads.com/
|
||||
# Support: http://gossamer-threads.com/scripts/support/
|
||||
# Updated: [localtime]
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
HEADER
|
||||
});
|
||||
|
||||
$self->debug_level($self->{debug});
|
||||
|
||||
return $self;
|
||||
|
||||
$self->{priv_path} ||= '.';
|
||||
$self->{version} ||= $GList::VERSION;
|
||||
$self->{setup} ||= 0;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub tpl_load {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a hash of config variables for use in tempaltes.
|
||||
#
|
||||
my $t = {};
|
||||
while (my ($key, $val) = each %{$GList::CFG}) {
|
||||
(ref $val eq 'ARRAY') and ($val = join ",", @$val);
|
||||
(ref $val eq 'HASH') and do { my $tmp = ''; foreach (sort keys %$val) { $tmp .= "$_ = $val->{$_}, "; } chop $tmp; chop $tmp; $val = $tmp; };
|
||||
$t->{"cfg_$key"} = $GList::IN->html_escape($val);
|
||||
}
|
||||
return $t;
|
||||
}
|
||||
|
||||
sub defaults {
|
||||
# ------------------------------------------------------------------
|
||||
# Set sensible defaults for the config values, overwriting old values.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{setup} = 1;
|
||||
$self->default_path(1);
|
||||
$self->default_misc(1);
|
||||
}
|
||||
|
||||
sub create_defaults {
|
||||
# ------------------------------------------------------------------
|
||||
# Create defaults, does not overwrite old values.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{setup} = 1;
|
||||
$self->default_path(0);
|
||||
$self->default_misc(0);
|
||||
}
|
||||
|
||||
sub set {
|
||||
# ------------------------------------------------------------------
|
||||
# Sets a value.
|
||||
#
|
||||
my ($self, $key, $val, $overwrite) = @_;
|
||||
if ($overwrite or ! exists $self->{$key}) { $self->{$key} = $val }
|
||||
}
|
||||
|
||||
sub default_path {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the path settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('cgi_url', _find_cgi_url(), $overwrite);
|
||||
$self->set('image_url', _find_image_url(), $overwrite);
|
||||
$self->set('path_to_perl', _find_perl(), $overwrite);
|
||||
$self->set('path_fileman', $self->{priv_path}, $overwrite);
|
||||
}
|
||||
|
||||
sub default_misc {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the misc settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('reg_number', '', $overwrite);
|
||||
$self->set('debug_level', 0, $overwrite);
|
||||
$self->set('user_session', '', $overwrite);
|
||||
$self->set('session_exp', 3, $overwrite);
|
||||
$self->set('scheduled_mailing_minute', 5, $overwrite);
|
||||
$self->set('admin_email', '', $overwrite);
|
||||
$self->set('smtp_server', '', $overwrite);
|
||||
$self->set('mail_path', _find_sendmail(), $overwrite);
|
||||
$self->set('highlight_color', 1, $overwrite);
|
||||
|
||||
# for attachments
|
||||
$self->set('max_attachments_size', 1024, $overwrite);
|
||||
|
||||
# for templates
|
||||
my $html_code = <<'HTML';
|
||||
<!-- CODE BEGINS-->
|
||||
<form method="post" action="<%url%>">
|
||||
Join <%name%>!<br>
|
||||
Email Address: <input name=email width=40><br>
|
||||
Name: <input name=name width=40><br>
|
||||
<select name="do">
|
||||
<option value="subscribe">Subscribe</option>
|
||||
<option value="unsubscribe">Unsubscribe</option>
|
||||
<input Type=submit value="Go">
|
||||
<input type=hidden name="lid" value="<%id%>">
|
||||
</form>
|
||||
<!-- CODE ENDS -->
|
||||
HTML
|
||||
|
||||
$self->set('html_code', $html_code, $overwrite);
|
||||
}
|
||||
|
||||
sub _find_cgi_url {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns basedir of current url.
|
||||
#
|
||||
my $url = GT::CGI->url({ absolute => 1, query_string => 0 });
|
||||
$url =~ s,/[^/]*$,,;
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub _find_image_url {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns image directory basedir from cgi basedir, replacing cgi with images
|
||||
#
|
||||
my $url = _find_cgi_url();
|
||||
$url =~ s,/cgi$,,;
|
||||
$url .= '/images';
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub _find_perl {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns path to perl.
|
||||
#
|
||||
my @poss_perls = qw(
|
||||
/usr/local/bin/perl /usr/bin/perl /bin/perl
|
||||
/usr/local/bin/perl5 /usr/bin/perl5 /bin/perl5
|
||||
/perl/bin/perl.exe c:/perl/bin/perl.exe d:/perl/bin/perl.exe
|
||||
);
|
||||
foreach my $perl_path (@poss_perls) {
|
||||
return $perl_path if -f $perl_path and -x _;
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
sub _find_sendmail {
|
||||
# ------------------------------------------------------------------
|
||||
# Looks for sendmail.
|
||||
#
|
||||
for (qw(/usr/sbin/sendmail /usr/lib/sendmail /usr/bin/sendmail /sbin/sendmail /bin/sendmail)) {
|
||||
return $_ if -f and -x _;
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
73
site/glist/lib/GList/Config/Data.pm
Normal file
73
site/glist/lib/GList/Config/Data.pm
Normal file
@ -0,0 +1,73 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website: http://gossamer-threads.com/
|
||||
# Support: http://gossamer-threads.com/scripts/support/
|
||||
# Updated: Sat Feb 12 12:02:26 2022
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
{
|
||||
'admin' => {
|
||||
'admin' => [
|
||||
'$GT$YJ4E9RP4$khwtQz/NC7ErNdHmPNOAE0',
|
||||
'slowman@slowtwitch.com'
|
||||
],
|
||||
'rappstar' => [
|
||||
'$GT$HQRmVMKU$qsarcJtu/9LHJtzyZBTJt.',
|
||||
'rappstar@slowtwitch.com'
|
||||
]
|
||||
},
|
||||
'admin_email' => '',
|
||||
'allowed_space' => '100000',
|
||||
'cgi_url' => 'https://secure.slowtwitch.com/cgi-bin',
|
||||
'command_time_out' => '10',
|
||||
'debug_level' => '0',
|
||||
'highlight_color' => '1',
|
||||
'html_code' => '<!-- CODE BEGINS-->
|
||||
<form method="post" action="<%url%>">
|
||||
Join <%name%>!<br>
|
||||
Email Address: <input name=email width=40><br>
|
||||
Name: <input name=name width=40><br>
|
||||
<select name="do">
|
||||
<option value="user_subscribe">Subscribe</option>
|
||||
<option value="user_unsubscribe">Unsubscribe</option>
|
||||
</select>
|
||||
<input Type=submit value="Go">
|
||||
<input type=hidden name="lid" value="<%id%>">
|
||||
</form>
|
||||
<!-- CODE ENDS -->
|
||||
',
|
||||
'iframe_tracking' => '1',
|
||||
'image_path' => '/home/slowtwitch/secure.slowtwitch.com/secure-www/glist',
|
||||
'image_url' => 'https://secure.slowtwitch.com/glist',
|
||||
'mail_path' => '/usr/sbin/sendmail',
|
||||
'max_attachments_size' => '1024',
|
||||
'max_bounced_emails' => '10000',
|
||||
'path_fileman' => '/home/slowtwitch/site/glist',
|
||||
'path_to_perl' => '/usr/bin/perl',
|
||||
'priv_path' => '/home/slowtwitch/site/glist',
|
||||
'reg_number' => '',
|
||||
'scheduled_mailing_minute' => '5',
|
||||
'session_exp' => '3',
|
||||
'setup' => '1',
|
||||
'signup_admin_validate' => '0',
|
||||
'signup_email_validate' => '1',
|
||||
'signup_enable' => '0',
|
||||
'signup_limit_email30' => '100',
|
||||
'signup_limit_list' => '10',
|
||||
'signup_limit_sublist' => '10',
|
||||
'signup_restricted_email' => [],
|
||||
'signup_username_regex' => '^[\w\-\.]{3,}$',
|
||||
'smtp_server' => '',
|
||||
'static_url' => 'https://secure.slowtwitch.com/glist',
|
||||
'template_backups' => '1',
|
||||
'template_set' => 'gossamer',
|
||||
'user_session' => '0',
|
||||
'version' => '1.1.1'
|
||||
};
|
||||
|
||||
# vim:syn=perl:ts=4:noet
|
||||
30
site/glist/lib/GList/Custom.pm
Normal file
30
site/glist/lib/GList/Custom.pm
Normal file
@ -0,0 +1,30 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Custom.pm,v 1.1 2004/01/13 01:19:23 jagerman 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.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# By default, this file is empty, however it is here to allow installations
|
||||
# to perform special operations required to make Gossamer Mail load.
|
||||
# For example, some installations might need a 'use lib' line to work
|
||||
# properly.
|
||||
#
|
||||
# This file will NOT be overwritten when upgrading your installation, so you
|
||||
# do not need to worry about additions made here being overwritten. This is
|
||||
# generally loaded after GMail.pm has started loading, but before any other
|
||||
# modules are loaded.
|
||||
#
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
1; # This must remain at the bottom of the file
|
||||
249
site/glist/lib/GList/GUI.pm
Normal file
249
site/glist/lib/GList/GUI.pm
Normal file
@ -0,0 +1,249 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: GUI.pm,v 1.5 2004/08/24 19:28:37 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::GUI;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects/;
|
||||
|
||||
sub gui_profile_form {
|
||||
# -------------------------------------------------------------------
|
||||
require GT::SQL::Display::HTML;
|
||||
require GT::SQL::Display::HTML::Table;
|
||||
|
||||
my $opts = {@_};
|
||||
my $user_tb = $DB->table('Users');
|
||||
|
||||
$opts->{cols} ||= [ grep(/^pro_/, $user_tb->ordered_columns) ];
|
||||
$opts->{tr} ||= 'class="body"';
|
||||
$opts->{td_l} ||= 'class="body" width="40%" align="right"';
|
||||
$opts->{td_r} ||= 'class="body" align="left"';
|
||||
$opts->{cols} ||= [];
|
||||
$opts->{mode} ||= 'edit';
|
||||
$opts->{required} ||= ($opts->{mode} eq 'search') ? '' : '*';
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $cols = $user_tb->cols;
|
||||
my $disp = $DB->html($user_tb, GT::Template->tags);
|
||||
my $html = '';
|
||||
my $prefix = $opts->{prefix} || '';
|
||||
|
||||
if ( $opts->{mode} eq 'hidden' ) {
|
||||
|
||||
# Preserve all columns that relate to the Users database
|
||||
my $cols = $user_tb->cols;
|
||||
my $hidden_html = '';
|
||||
foreach my $col ( keys %$cols ) {
|
||||
foreach my $name ( map { "$col$_" } ( '', qw( -opt -gt -lt -le -ge -ne )) ) {
|
||||
my $v = $tags->{$name};
|
||||
next unless defined $v;
|
||||
my $input_html = gui_form_control({
|
||||
form_type => 'hidden',
|
||||
value => $v,
|
||||
name => $name
|
||||
});
|
||||
$html .= $$input_html;
|
||||
}
|
||||
}
|
||||
return \$html;
|
||||
}
|
||||
|
||||
my %search_defs = (
|
||||
string => { names => [qw( LIKE <> = )] },
|
||||
number => { names => [qw( = <> < <= > >= )] },
|
||||
date => { names => [ '', qw( = <> < <= > >= )] },
|
||||
radio => { names => [qw( = <> )] },
|
||||
minimal => { names => [qw( = )] }
|
||||
);
|
||||
|
||||
foreach my $col (@{$opts->{cols}}) {
|
||||
my $control_opts = {%{$cols->{$col}||{}}};
|
||||
$control_opts->{name} = $col;
|
||||
$control_opts->{value} = $tags->{$col};
|
||||
my $title = GList::language( $cols->{$col}{form_display} );
|
||||
my $input_html = gui_form_control({
|
||||
name => "$prefix$col",
|
||||
value=> ($opts->{mode} eq 'search') ? '' : $tags->{"$prefix$col"},
|
||||
def => $control_opts
|
||||
});
|
||||
$html .= ( $cols->{$col}->{not_null} ) ?
|
||||
"<tr $opts->{tr}><td $opts->{td_l}><ul/>$title</td><td $opts->{td_r}>$$input_html $opts->{required}</td></tr>" :
|
||||
"<tr $opts->{tr}><td $opts->{td_l}><ul/>$title</td><td $opts->{td_r}>$$input_html</td></tr>";
|
||||
}
|
||||
return \$html;
|
||||
}
|
||||
|
||||
sub gui_form_control {
|
||||
# -------------------------------------------------------------------
|
||||
require GT::SQL::Display::HTML;
|
||||
require GT::SQL::Display::HTML::Table;
|
||||
require GT::Template;
|
||||
|
||||
my $opts = ref $_[0] eq 'HASH' ? shift : {@_};
|
||||
|
||||
my $user_tb = $DB->table('Users');
|
||||
my $tags = GT::Template->tags || {};
|
||||
my $disp = $DB->html($user_tb, $tags);
|
||||
|
||||
my $form_type = lc $opts->{def}->{form_type};
|
||||
exists $opts->{blank} or $opts->{blank} = $form_type eq 'select' ? 1 : 0;
|
||||
|
||||
$opts->{def}->{class} = 'object' if ($form_type !~ /radio|checkbox/);
|
||||
my $input_html = 'radio' eq $form_type ? $disp->radio( $opts ) :
|
||||
'checkbox' eq $form_type ? $disp->checkbox( $opts ) :
|
||||
'select' eq $form_type ? $disp->select( $opts ) :
|
||||
'hidden' eq $form_type ? $disp->hidden( $opts ) :
|
||||
'multiple' eq $form_type ? $disp->multiple( $opts ) :
|
||||
'textarea' eq $form_type ? $disp->textarea( $opts ) :
|
||||
'file' eq $form_type ? "File type not supported." :
|
||||
'date' eq $form_type ? do {
|
||||
require GT::Date;
|
||||
my ($sel_year, $sel_mon, $sel_day) = split /\-/, GT::CGI::html_escape($opts->{value});
|
||||
$sel_year ||= 1970;
|
||||
$sel_mon ||= 1;
|
||||
$sel_day ||= 1;
|
||||
my $month_sel = $disp->select({
|
||||
name => "$opts->{name}-mon",
|
||||
value => $sel_mon,
|
||||
values => { map { sprintf("%02d", $_) => $GT::Date::LANGUAGE->{short_month_names}->[$_ - 1] } (1 .. 12) },
|
||||
sort => [ map { sprintf("%02d", $_) } (1 .. 12) ],
|
||||
blank => 0
|
||||
});
|
||||
my $day_sel = $disp->select({
|
||||
name => "$opts->{name}-day",
|
||||
value => $sel_day,
|
||||
values => { map { sprintf("%02d", $_) => $_ } (1 .. 31) },
|
||||
sort => [ map { sprintf("%02d", $_) } (1 .. 31) ],
|
||||
blank => 0
|
||||
});
|
||||
qq~
|
||||
$day_sel /
|
||||
$month_sel /
|
||||
<input type="text" name="$opts->{name}-year" value="$sel_year" size="4" maxlength="4">
|
||||
~;
|
||||
} :
|
||||
$disp->text($opts);
|
||||
|
||||
return \$input_html;
|
||||
}
|
||||
|
||||
sub gui_toolbar {
|
||||
my %input = @_;
|
||||
my $tags = GT::Template->tags;
|
||||
$input{first} ||= q|<img src="$image_url/icons/first.gif" border="0" width="17" height="11" alt="First page">|;
|
||||
$input{first_grey} ||= q|<img src="$image_url/icons/first_grey.gif" border="0" width="17" height="11" alt="First page">|;
|
||||
$input{prev} ||= q|<img src="$image_url/icons/prev.gif" border="0" width="10" height="11" alt="Previous page">|;
|
||||
$input{prev_grey} ||= q|<img src="$image_url/icons/prev_grey.gif" border="0" width="10" height="11" alt="Previous page">|;
|
||||
$input{next} ||= q|<img src="$image_url/icons/next.gif" border="0" width="10" height="11" alt="Next page">|;
|
||||
$input{next_grey} ||= q|<img src="$image_url/icons/next_grey.gif" border="0" width="10" height="11" alt="Next page">|;
|
||||
$input{last} ||= q|<img src="$image_url/icons/last.gif" border="0" width="17" height="11" alt="Last page">|;
|
||||
$input{last_grey} ||= q|<img src="$image_url/icons/last_grey.gif" border="0" width="17" height="11" alt="Last page">|;
|
||||
$input{view_all} ||= q|View All|;
|
||||
$input{pages} ||= 9;
|
||||
$input{'...'} ||= '...';
|
||||
$input{'first_...'} ||= 1;
|
||||
$input{'last_...'} ||= 1;
|
||||
$input{before_page} ||= q||;
|
||||
$input{after_page} ||= q||;
|
||||
$input{before_current} ||= q|<b>|;
|
||||
$input{after_current} ||= q|</b>|;
|
||||
$input{'glist.cgi'} ||= 'glist.cgi';
|
||||
|
||||
for (keys %input) {
|
||||
$input{$_} =~ s/\$image_url/$tags->{image_url}/g;
|
||||
}
|
||||
|
||||
my $hidden_query = ${$tags->{hidden_query} || \''};
|
||||
|
||||
my $num_page_items = ref $tags->{num_page_items} eq 'SCALAR' ? ${$tags->{num_page_items}} : $tags->{num_page_items};
|
||||
my $paging = GList::paging($num_page_items, @$tags{qw/mh nh/}, @input{qw/pages last_.../});
|
||||
($paging, my ($top_page, $ddd)) = @$paging{'paging', 'top_page', 'dotdotdot'};
|
||||
my $return = '';
|
||||
my $search = '';
|
||||
if ($tags->{toolbar_table}) {
|
||||
my $cols = $DB->table($tags->{toolbar_table})->cols;
|
||||
foreach my $c (keys %{$cols}) {
|
||||
next unless $tags->{$c};
|
||||
$search .= qq|$c=$tags->{$c};|;
|
||||
if ($tags->{"$c-opt"}) { $search .= qq|$c-opt=$tags->{"$c-opt"};|; }
|
||||
}
|
||||
}
|
||||
|
||||
my $link = sub {
|
||||
my ($page, $disp) = @_;
|
||||
$return .= qq|<a href="$input{'glist.cgi'}?do=$tags->{do};|;
|
||||
if ($tags->{toolbar_query}) {
|
||||
my $query = ref $tags->{toolbar_query} ? ${$tags->{toolbar_query}} : $tags->{toolbar_query};
|
||||
$return .= qq|$query;|;
|
||||
}
|
||||
if ($search) {
|
||||
$return .= qq|$search|;
|
||||
}
|
||||
$return .= qq|nh=$page;|;
|
||||
if ($tags->{users}) { $return .= qq|users=1;| }
|
||||
if ($tags->{show_user}) { $return .= qq|show_user=1;| }
|
||||
if ($tags->{fd}) { $return .= qq|fd=$tags->{fd};| }
|
||||
if ($tags->{sb}) { $return .= qq|sb=$tags->{sb};| }
|
||||
if ($tags->{so}) { $return .= qq|so=$tags->{so};| }
|
||||
if ($tags->{mh}) { $return .= qq|mh=$tags->{mh};| }
|
||||
if ($tags->{id}) { $return .= qq|id=$tags->{id};| }
|
||||
if ($tags->{cs}) { $return .= qq|cs=$tags->{cs};| }
|
||||
if ($tags->{first}) { $return .= qq|first=$tags->{first};| }
|
||||
if ($tags->{mn_disable}){ $return .= qq|mn_disable=1;| }
|
||||
|
||||
$return .= qq|$hidden_query">$disp</a>\n|;
|
||||
};
|
||||
|
||||
unless ($top_page == 1) {
|
||||
if ($tags->{nh} == 1) {
|
||||
$return .= $input{first_grey} . "\n";
|
||||
$return .= $input{prev_grey} . "\n";
|
||||
}
|
||||
else {
|
||||
my $prev = ($tags->{nh} == -1) ? 1 : ($tags->{nh} - 1);
|
||||
$link->(1, $input{first});
|
||||
$link->($prev, $input{prev});
|
||||
}
|
||||
|
||||
if (@$paging and $paging->[0]->{page_num} > 1 and $input{'first_...'}) {
|
||||
$link->(1, qq|$input{before_page}1$input{after_page}|);
|
||||
$return .= "$input{before_page}$input{'...'}" . ($input{after_page} || " ") if $paging->[0]->{page_num} > 2;
|
||||
}
|
||||
for (@$paging) {
|
||||
if ($_->{is_current_page}) {
|
||||
$return .= qq|$input{before_current}$_->{page_num}$input{after_current}\n|;
|
||||
}
|
||||
else {
|
||||
$link->($_->{page_num}, qq|$input{before_page}$_->{page_num}$input{after_page}|);
|
||||
}
|
||||
}
|
||||
if ($ddd) {
|
||||
$return .= "$input{before_page}$input{'...'}" . ($input{after_page} || " ");
|
||||
$link->($top_page, "$input{before_page}$top_page$input{after_page}");
|
||||
}
|
||||
|
||||
if ($tags->{nh} >= $top_page) {
|
||||
$return .= $input{next_grey} . "\n";
|
||||
$return .= $input{last_grey} . "\n";
|
||||
}
|
||||
else {
|
||||
my $next = ($tags->{nh} == -1) ? 1 : ($tags->{nh} + 1);
|
||||
$link->($next, $input{next});
|
||||
$link->($top_page, $input{last});
|
||||
}
|
||||
}
|
||||
return \$return;
|
||||
}
|
||||
1;
|
||||
88
site/glist/lib/GList/HTML.pm
Normal file
88
site/glist/lib/GList/HTML.pm
Normal file
@ -0,0 +1,88 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: HTML.pm,v 1.10 2004/03/01 21:38:38 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::HTML;
|
||||
|
||||
use strict;
|
||||
use GList q/:objects/;
|
||||
|
||||
sub date_get {
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
my ($fld_name, $type) = @_;
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $format = $tags->{usr_date_format};
|
||||
$format =~ s/\#/\%/g;
|
||||
$format ||= '%mm%-%dd%-%yyyy%';
|
||||
$format .= ' %hh%:%MM%:%ss%' if ( $type );
|
||||
|
||||
require GT::Date;
|
||||
( $fld_name ) or return GT::Date::date_get(time, $format);
|
||||
|
||||
my $record = $tags->{results}[$tags->{row_num} - 1];
|
||||
return GT::Date::date_get($record->{$fld_name} || $tags->{$fld_name}, $format);
|
||||
}
|
||||
|
||||
sub html_unescape {
|
||||
#--------------------------------------------------------------------
|
||||
#
|
||||
my $content = shift;
|
||||
$content =~ s/\n/<br>/g;
|
||||
return $content;
|
||||
}
|
||||
|
||||
sub generate_attachments {
|
||||
#---------------------------------------------------------------------
|
||||
#
|
||||
my $col = shift || 'msg_id';
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $val = $tags->{results}[$tags->{row_num} - 1]->{$col};
|
||||
( $val ) or return;
|
||||
|
||||
my $sth;
|
||||
if ( $col eq 'msg_id' ) {
|
||||
$sth = $tags->{html}->{sql}->table('MessageAttachments')->select({ att_message_id_fk => $val });
|
||||
}
|
||||
else {
|
||||
$sth = $tags->{html}->{sql}->table('MailingAttachments')->select({ mat_mailing_id_fk => $val });
|
||||
}
|
||||
my $attachments;
|
||||
while ( my $rs = $sth->fetchrow_hashref ) {
|
||||
push @$attachments, $rs;
|
||||
}
|
||||
|
||||
return { attachments => ( !$attachments ) ? 0 : $attachments };
|
||||
}
|
||||
|
||||
sub generate_years {
|
||||
#-------------------------------------------------------------------
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
my $min = $tags->{html}->{sql}->table('MailingIndex')->select(['MIN(mli_done)'])->fetchrow_array || time;
|
||||
|
||||
require GT::Date;
|
||||
my $yy_min = GT::Date::date_get($min, '%yyyy%');
|
||||
my $yy_max = GT::Date::date_get(time, '%yyyy%');
|
||||
my @output;
|
||||
for my $i ( $yy_min .. $yy_max ) {
|
||||
push @output, { y => $i };
|
||||
}
|
||||
return { loop_years => \@output };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
833
site/glist/lib/GList/List.pm
Normal file
833
site/glist/lib/GList/List.pm
Normal file
@ -0,0 +1,833 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: List.pm,v 1.50 2004/11/04 17:54:05 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::List;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects :user_type $DEBUG/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
sub process {
|
||||
#-------------------------------------------------------------------
|
||||
# Setermine what to do
|
||||
#
|
||||
my $do = shift;
|
||||
|
||||
my $action = _determine_action($do) or die "Error: Invalid Action! ($do)";
|
||||
my ($tpl, $results) = GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action);
|
||||
|
||||
$tpl ||= 'lst_home.html';
|
||||
$MN_SELECTED = 2;
|
||||
|
||||
my $hidden = GList::hidden();
|
||||
$results->{hidden_query} = $hidden->{hidden_query};
|
||||
$results->{hidden_objects} = $hidden->{hidden_objects};
|
||||
GList::display($tpl, $results);
|
||||
}
|
||||
|
||||
$COMPILE{lst_home} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_home {
|
||||
#--------------------------------------------------------------------
|
||||
# Print home page
|
||||
#
|
||||
my $msg = shift;
|
||||
my $cgi = $IN->get_hash;
|
||||
if (defined $cgi->{do} and $cgi->{do} =~ /^lst_add|lst_modify|lst_html/) {
|
||||
foreach ( $DB->table('Lists')->cols ) { $cgi->{$_} = ''; }
|
||||
}
|
||||
my $search_check = ($IN->param('do') eq 'lst_search') ? 1 : 0;
|
||||
my $query = '';
|
||||
if ($cgi->{'lst_date_created-ge'} or $cgi->{'lst_date_created-le'}) {
|
||||
my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
require GT::Date;
|
||||
if ($cgi->{'lst_date_created-ge'}) {
|
||||
$query .= "lst_date_created-ge=$cgi->{'lst_date_created-ge'};";
|
||||
$valid_from = GList::date_to_time($cgi->{'lst_date_created-ge'}, $format);
|
||||
$cgi->{'lst_date_created-ge'} = GT::Date::date_get($valid_from, $format);
|
||||
}
|
||||
if ($cgi->{'lst_date_created-le'}) {
|
||||
$query .= "lst_date_created-le=$cgi->{'lst_date_created-le'};";
|
||||
$valid_to = GList::date_to_time($cgi->{'lst_date_created-le'}, $format);
|
||||
$cgi->{'lst_date_created-le'} = GT::Date::date_get($valid_to, $format);
|
||||
}
|
||||
|
||||
if ($search_check and (!$valid_from or !$valid_to)) {
|
||||
$format =~ s/\%//g;
|
||||
return lst_search_form(GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')));
|
||||
}
|
||||
}
|
||||
my $results = GList::search(
|
||||
cgi => $cgi,
|
||||
db => $DB->table('Lists'),
|
||||
prefix => 'lst',
|
||||
sb => 'lst_title',
|
||||
so => 'ASC',
|
||||
search_check=> $search_check,
|
||||
select_all => $cgi->{select_all}
|
||||
);
|
||||
|
||||
if (ref $results ne 'HASH') {
|
||||
($IN->param('do') eq 'lst_search') ? return (lst_search_form($results))
|
||||
: return ('lst_home.html', { msg => $results });
|
||||
}
|
||||
elsif ($results->{error} and $search_check) {
|
||||
return lst_search_form($results->{error});
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
my $subs = $DB->table('Subscribers');
|
||||
my $output = $results->{results};
|
||||
my @lists = map $_->{lst_id}, @$output;
|
||||
|
||||
$subs->select_options("GROUP BY sub_list_id_fk");
|
||||
my %subscribers = $subs->select(sub_list_id_fk => 'COUNT(*)', { sub_list_id_fk => \@lists })->fetchall_list;
|
||||
|
||||
$subs->select_options("GROUP BY sub_list_id_fk");
|
||||
my %validateds = $subs->select(sub_list_id_fk => 'COUNT(*)', { sub_list_id_fk => \@lists, sub_validated => 1 })->fetchall_list;
|
||||
|
||||
$subs->select_options("GROUP BY sub_list_id_fk");
|
||||
my %bounceds = $subs->select(sub_list_id_fk => 'COUNT(*)', GT::SQL::Condition->new(sub_list_id_fk => 'IN' => \@lists, sub_bounced => '>=' => 1))->fetchall_list;
|
||||
|
||||
foreach my $rs (@$output) {
|
||||
$rs->{subscribers} = $subscribers{$rs->{lst_id}};
|
||||
$rs->{validateds} = $validateds{$rs->{lst_id}};
|
||||
$rs->{bounceds} = $bounceds{$rs->{lst_id}};
|
||||
}
|
||||
|
||||
if ($cgi->{select_all}) {
|
||||
my $sorted = _qsort($results->{results}, $cgi->{sb}, ($cgi->{so} eq 'ASC') ? 1 : 0);
|
||||
my @sorted;
|
||||
my $mh = $results->{mh};
|
||||
my $nh = $results->{nh} || 1;
|
||||
my $bg = ( $nh == 1 ) ? 0 : ( $nh - 1 ) * $mh;
|
||||
my $count = 0;
|
||||
if ( $bg < $results->{hits} ) {
|
||||
foreach my $i (0..($results->{hits} - 1)) {
|
||||
if ($i >= $bg) {
|
||||
push @sorted, $sorted->[$i];
|
||||
last if ($#sorted == $mh - 1);
|
||||
}
|
||||
}
|
||||
$results->{results} = \@sorted;
|
||||
}
|
||||
else {
|
||||
$results->{results} = [];
|
||||
}
|
||||
}
|
||||
$results->{msg} = $msg if ($msg);
|
||||
return ('lst_home.html', { %$results, toolbar_query => $query });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_add} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_add {
|
||||
#--------------------------------------------------------------------
|
||||
#
|
||||
return ('lst_add_form.html') if ($IN->param('form'));
|
||||
|
||||
# Check account limit if it's a limited user
|
||||
if ($USER->{usr_type} == LIMITED_USER and GList::check_limit('list')) {
|
||||
return lst_home($GList::error);
|
||||
}
|
||||
|
||||
my $ret = GList::add('Lists', 'lst');
|
||||
return ('lst_add_form.html', { msg => "<font color=red>$GList::error</font>", help => 'lists_add.html' }) if ( $GList::error );
|
||||
|
||||
my $name = $IN->param('lst_title');
|
||||
return lst_home(GList::language('LST_ADD_SUCCESS', $name));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_modify_form} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_modify_form {
|
||||
#--------------------------------------------------------------------
|
||||
# Print modify form
|
||||
#
|
||||
my $msg = shift;
|
||||
|
||||
return lst_home(GList::language('LST_INVALID')) unless ($IN->param('lst_id'));
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $IN->param('lst_id'));
|
||||
return home($info) if (ref $info ne 'HASH');
|
||||
|
||||
return ('lst_modify_form.html', { msg => $msg, %$info, help => 'lists_add.html' });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_modify} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_modify {
|
||||
#--------------------------------------------------------------------
|
||||
#
|
||||
GList::modify('Lists', 'lst');
|
||||
return lst_modify_form("<font color=red>$GList::error</font>") if ( $GList::error );
|
||||
|
||||
my $title = $IN->param('lst_title');
|
||||
lst_home(GList::language('LST_MOD_SUCCESS', $title));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_search_form} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_search_form {
|
||||
#--------------------------------------------------------------------
|
||||
# Print add form
|
||||
#
|
||||
my $msg = shift;
|
||||
return ('lst_search_form.html', { msg => $msg });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_delete} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_delete {
|
||||
#--------------------------------------------------------------------
|
||||
# Delete lists
|
||||
#
|
||||
return lst_home(GList::delete('Lists', 'lst'));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_html} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_html {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
return lst_home(GList::language('LST_INVALID')) unless ($IN->param('lst_id'));
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $IN->param('lst_id'));
|
||||
return lst_home($info) if (ref $info ne 'HASH');
|
||||
|
||||
my $msg = $CFG->{html_code};
|
||||
$msg =~ s/<%name%>/$info->{lst_title}/;
|
||||
$msg =~ s/<%id%>/$info->{lst_id}/;
|
||||
$msg =~ s/<%url%>/$CFG->{cgi_url}\/glist.cgi/;
|
||||
return ('lst_html.html', { msg => $msg, lst_title => $info->{lst_title} });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_import} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_import {
|
||||
#-----------------------------------------------------------------
|
||||
# Import data into subcribers table
|
||||
#
|
||||
return ('lst_import_form.html', { help => 'lists_import.html' }) if ($IN->param('form'));
|
||||
|
||||
my $data = $IN->param('sub_file') || $IN->param('sub_data');
|
||||
return ('lst_import_form.html', { msg => GList::language('LST_IPT_INVALID'), help => 'lists_import.html' }) unless ($data);
|
||||
return ('lst_import_form.html', { msg => GList::language('LST_IPT_LIST_EMPTY'), help => 'lists_import.html' }) unless ($IN->param('import_to'));
|
||||
|
||||
my $import_to = (ref $IN->param('import_to') eq 'ARRAY') ? $IN->param('import_to') : [$IN->param('import_to')];
|
||||
my $fd = $IN->param('fd') || ',';
|
||||
my $fe = $IN->param('fe') || '\\';
|
||||
my $rd = $IN->param('rd') || '\n';
|
||||
my $rl = $IN->param('rl') || 0;
|
||||
|
||||
# Setup the language for GT::SQL.
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = GList::language('LST_IPT_DUPLICATE_EMAIL');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = GList::language('LST_IMP_NOTNULL') if ( GList::language('LST_IMP_NOTNULL') );
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = '';
|
||||
|
||||
my (@data, @results);
|
||||
if ($IN->param('sub_file')) { # from a text file
|
||||
my $file_name = $data;
|
||||
$file_name =~ s/.*?([^\\\/:]+)$/$1/;
|
||||
$file_name =~ s/[\[\]\s\$\#\%'"]/\_/g;
|
||||
$file_name = "$CFG->{priv_path}/tmp/$file_name";
|
||||
open (OUTFILE, "> $file_name") ;
|
||||
binmode(OUTFILE);
|
||||
my ($bytesread, $buffer, $count);
|
||||
while ($bytesread = read($data, $buffer, 1024)) {
|
||||
$buffer =~ s,\r\n,\n,g;
|
||||
print OUTFILE $buffer;
|
||||
}
|
||||
close OUTFILE;
|
||||
|
||||
if (!-T $file_name) {
|
||||
unlink $file_name;
|
||||
return lst_import_form(GList::language('LST_IPT_INVALID_FILE'));
|
||||
}
|
||||
|
||||
open (DATA, "< $file_name");
|
||||
my @lines = <DATA>;
|
||||
close DATA;
|
||||
unlink $file_name;
|
||||
|
||||
LINE: foreach (@lines) {
|
||||
$count++;
|
||||
( /^#/ ) and next LINE;
|
||||
( /^\s*$/ ) and next LINE;
|
||||
( $count eq $rl ) and next LINE;
|
||||
push @data, $_;
|
||||
}
|
||||
}
|
||||
else { # from listings
|
||||
@data = split(/$rd/, $data);
|
||||
}
|
||||
foreach my $id (@$import_to) {
|
||||
my $results = _import_subscriber($id, \@data);
|
||||
if (ref $results eq 'HASH') {
|
||||
push @results, $results;
|
||||
}
|
||||
else {
|
||||
push @results, { lst_id => $id, error => $results };
|
||||
}
|
||||
}
|
||||
return ('lst_import_success.html', { import_results => \@results });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_import_subscriber} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _import_subscriber {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
my ($list_id, $data) = @_;
|
||||
|
||||
# Verify data before importing
|
||||
return GList::language('LST_INVALID') if (!$list_id or !$data);
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $list_id);
|
||||
return $info if (ref $info ne 'HASH');
|
||||
|
||||
if (GList::check_limit('sublist', $list_id)) {
|
||||
return { list_name => $info->{lst_title}, overlimit => 1 };
|
||||
}
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $fd = $IN->param('fd') || ',';
|
||||
my $fe = $IN->param('fe') || '\\';
|
||||
my $rd = $IN->param('rd') || '\n';
|
||||
my $rl = $IN->param('rl') || 0;
|
||||
|
||||
# Create stoplist database and load wild cards
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
|
||||
my @results;
|
||||
my ($invalid, $duplicate) = (0, 0);
|
||||
foreach my $row ( @$data ) {
|
||||
$row =~ s/[\r\n\"]//g; # Remove Windows linefeed character.
|
||||
if ($IN->param('cname')) {
|
||||
my ($n, $e) = split(/$fd/, $row);
|
||||
$e = $1 if ($e =~ /<([^> ]+)>/);
|
||||
$e = lc $e;
|
||||
my $error = _check_subscriber($e, $list_id, $db_stl, $wild_cards);
|
||||
if ($error) {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $e || $n, status => $error };
|
||||
$invalid++;
|
||||
}
|
||||
else {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $e || $n, status => '' };
|
||||
if ($db->count({ sub_email => $e, sub_list_id_fk => $list_id })) {
|
||||
$db->update({ sub_name => $n }, { sub_email => $e, sub_list_id_fk => $list_id }) if $n;
|
||||
$results[-1]->{status} = GList::language('SYS_DUPLICATE');
|
||||
$duplicate++;
|
||||
}
|
||||
else {
|
||||
$db->insert({ sub_email => $e, sub_name => $n, sub_created => time, sub_list_id_fk => $list_id, sub_user_id_fk => $info->{lst_user_id_fk} });
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$row = $1 if ($row =~ /<([^> ]+)>/);
|
||||
$row = lc $row;
|
||||
my $error = _check_subscriber($row, $list_id, $db_stl, $wild_cards);
|
||||
if ($error) {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $row, status => $error };
|
||||
$invalid++;
|
||||
}
|
||||
else {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $row, status => '' };
|
||||
if ($db->count({ sub_email => $row, sub_list_id_fk => $list_id })) {
|
||||
$results[-1]->{status} = GList::language('SYS_DUPLICATE');
|
||||
$duplicate++;
|
||||
}
|
||||
else {
|
||||
$db->insert({ sub_email => $row, sub_created => time, sub_list_id_fk => $list_id, sub_user_id_fk => $info->{lst_user_id_fk} });
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return {
|
||||
list_name => $info->{lst_title},
|
||||
results => \@results,
|
||||
invalid => $invalid,
|
||||
duplicate => $duplicate,
|
||||
hits => scalar @results,
|
||||
successful => scalar @results - $invalid - $duplicate,
|
||||
declined => $invalid + $duplicate
|
||||
};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_check_subscriber} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _check_subscriber {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
my ($email, $lst_id, $db_stl, $wild_cards) = @_;
|
||||
return GList::language('LST_IPT_OVERLIMIT') if (GList::check_limit('sublist', $lst_id));
|
||||
return GList::language('LST_IPT_INVALID_EMAIL') if ($email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $email =~ /\s/ );
|
||||
return GList::language('LST_IPT_ON_STOPLIST') if ($db_stl->count({ stl_email => $email }));
|
||||
foreach (@$wild_cards) {
|
||||
my $e = $_->[0];
|
||||
my $re = quotemeta $e;
|
||||
$re =~ s/\\\*/.*/;
|
||||
$re =~ s/\\\?/./;
|
||||
return GList::language('LST_IPT_ON_STOPLIST') if ($email =~ /$re/i);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_subscribers} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_subscribers {
|
||||
#--------------------------------------------------------------------
|
||||
# Print add form
|
||||
#
|
||||
my $do = shift || 0;
|
||||
|
||||
my $msg = ($do and $do =~ /^\d+$/) ? _sub_modify($do) : $do;
|
||||
if ($do =~ /^\d+$/ and ($do =~ /3|4/ or ($do == 1 and $IN->param('unbounced_form')))) { # Reset bounced emails
|
||||
return lst_unsub_bounced($msg);
|
||||
}
|
||||
return ('lst_subscriber_form.html') if ($IN->param('form'));
|
||||
|
||||
my $alpha;
|
||||
my $cgi = $IN->get_hash();
|
||||
my $hidden = GList::hidden;
|
||||
|
||||
# Create condition for subscriber's quick search bar
|
||||
require GT::SQL::Condition;
|
||||
my $cd = GT::SQL::Condition->new(lst_user_id_fk => '=' => $USER->{usr_username});
|
||||
my $cols = $DB->table('Subscribers')->cols;
|
||||
my $url = "glist.cgi?do=lst_subscribers$hidden->{hidden_query}";
|
||||
my $query= '';
|
||||
foreach my $c (keys % $cols) {
|
||||
next if (!$cgi->{$c});
|
||||
if ($c eq 'sub_list_id_fk') {
|
||||
$cd->add($c => '=' => $cgi->{$c});
|
||||
}
|
||||
else {
|
||||
$cd->add($c => 'like' => "%$cgi->{$c}%");
|
||||
}
|
||||
$url .= ";$c=$cgi->{$c}";
|
||||
}
|
||||
|
||||
# Do a search from the main page
|
||||
if ($IN->param('sub_search') and $IN->param('search_val')) {
|
||||
$cgi->{$cgi->{search_col}} = $cgi->{search_val};
|
||||
$url .= ";$cgi->{search_col}=$cgi->{$cgi->{search_col}}" if $cgi->{search_val};
|
||||
$query .= ";$cgi->{search_col}=$cgi->{$cgi->{search_col}}" if $cgi->{search_val};
|
||||
}
|
||||
# And from quick search bar
|
||||
if ($IN->param('alpha') and $IN->param('alpha') ne 'all') {
|
||||
$alpha = $IN->param('alpha');
|
||||
$query .= ";alpha=$alpha";
|
||||
}
|
||||
|
||||
# Search on date fields
|
||||
my $search_check = ($IN->param('search_form')) ? 1 : 0;
|
||||
if ($cgi->{'sub_created-ge'} or $cgi->{'sub_created-le'}) {
|
||||
my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
|
||||
require GT::Date;
|
||||
if ($cgi->{'sub_created-ge'}) {
|
||||
$valid_from = GList::date_to_time($cgi->{'sub_created-ge'}, $format);
|
||||
$cgi->{'sub_created-ge'} = GT::Date::date_get($valid_from, $format) if ($valid_from);
|
||||
}
|
||||
if ($cgi->{'sub_created-le'}) {
|
||||
$valid_to = GList::date_to_time($cgi->{'sub_created-le'}, $format);
|
||||
$cgi->{'sub_created-le'} = GT::Date::date_get($valid_to, $format) if ($valid_to);
|
||||
}
|
||||
if ($search_check and (!$valid_from or !$valid_to)) {
|
||||
$format =~ s/\%//g;
|
||||
return ('lst_subscriber_form.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')) });
|
||||
}
|
||||
}
|
||||
if ($cgi->{sub_bounced}) {
|
||||
$cgi->{'sub_bounced-opt'} = '>=';
|
||||
}
|
||||
my $results = GList::search(
|
||||
cgi => $cgi,
|
||||
db => $DB->table('Subscribers'),
|
||||
prefix => 'sub',
|
||||
sb => 'sub_email',
|
||||
so => 'ASC',
|
||||
search_alpha=> $alpha,
|
||||
search_col => 'sub_email',
|
||||
search_check=> $search_check,
|
||||
show_user => $cgi->{show_user},
|
||||
return_msg => 'LST_SUB_RESULTS',
|
||||
);
|
||||
|
||||
my $page = ($IN->param('mn_disable')) ? 'lst_subscribers_preview.html' : 'lst_subscribers.html';
|
||||
my $subs_db = $DB->table('Lists', 'Subscribers');
|
||||
$subs_db->select_options('ORDER BY letter');
|
||||
|
||||
my $sth = $subs_db->select($cd, ['DISTINCT SUBSTRING(sub_email, 1, 1) as letter']);
|
||||
if (ref $results ne 'HASH') {
|
||||
$page = 'lst_subscriber_form.html' if ($search_check);
|
||||
return ($page, { msg => $msg || $results, search_bar => _search_bar($sth, $url) });
|
||||
}
|
||||
elsif ($results->{error} and $search_check) {
|
||||
return ('lst_subscriber_form.html', { msg => $results->{error} });
|
||||
}
|
||||
|
||||
if ($IN->param('mn_disable')) {
|
||||
$results->{msg} = '';
|
||||
}
|
||||
else {
|
||||
$results->{msg} = $msg if ($msg);
|
||||
}
|
||||
return ($page, { search_bar => _search_bar($sth, $url), toolbar_query => $query, %$results });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_sub_modify} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _sub_modify {
|
||||
#--------------------------------------------------------------------
|
||||
# Validate/delete subscribers user
|
||||
#
|
||||
my $do = shift;
|
||||
|
||||
# If they selected only one record to search we still need an array ref
|
||||
my $mod = ( ref $IN->param('modify') eq 'ARRAY' ) ? $IN->param('modify') : [$IN->param('modify')];
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $cgi = $IN->get_hash;
|
||||
|
||||
my ($msg, $rec_modified) = ('', 0);
|
||||
if ($do == 1) { # Delete subscribers
|
||||
foreach my $rec_num ( @{$mod} ) {
|
||||
my $info = GList::check_owner('Subscribers', 'sub', $cgi->{"$rec_num-sub_id"});
|
||||
next if (!$info);
|
||||
|
||||
my $ret = $db->delete({ sub_id => $info->{sub_id} });
|
||||
if (defined $ret and $ret != 0) {
|
||||
$rec_modified++;
|
||||
}
|
||||
}
|
||||
$msg = GList::language('LST_SUB_DELETED', $rec_modified);
|
||||
}
|
||||
elsif ($do == 2) { # Validate subscribers
|
||||
foreach my $rec_num ( @{$mod} ) {
|
||||
my $info = GList::check_owner('Subscribers', 'sub', $cgi->{"$rec_num-sub_id"});
|
||||
next if (!$info);
|
||||
|
||||
if ($db->count({ sub_id => $info->{sub_id}, sub_validated => 0 })) {
|
||||
$db->update({ sub_validated => 1 }, { sub_id => $info->{sub_id} });
|
||||
$rec_modified++;
|
||||
}
|
||||
}
|
||||
$msg = GList::language('LST_SUB_VALIDATED', $rec_modified);
|
||||
}
|
||||
elsif ($do == 3) { # Unbounced subscribers
|
||||
require GT::SQL::Condition;
|
||||
foreach my $rec_num ( @{$mod} ) {
|
||||
my $info = GList::check_owner('Subscribers', 'sub', $cgi->{"$rec_num-sub_id"});
|
||||
next if (!$info);
|
||||
|
||||
if ($db->count(GT::SQL::Condition->new(sub_id => '=' => $info->{sub_id}, sub_bounced => '>=' => 1))) {
|
||||
$db->update({ sub_bounced => '0' }, { sub_id => $info->{sub_id} });
|
||||
$rec_modified++;
|
||||
}
|
||||
}
|
||||
$msg = GList::language('LST_SUB_UNBOUNCED', $rec_modified);
|
||||
}
|
||||
elsif ($do == 4) { # Remove all unbounced subscribers
|
||||
require GT::SQL::Condition;
|
||||
my $cond = new GT::SQL::Condition;
|
||||
$cond->add(sub_bounced => '>=' => 1, sub_user_id_fk => '=' => $USER->{usr_username});
|
||||
$cond->add(sub_list_id_fk => '=', $cgi->{list_id}) if $cgi->{list_id};
|
||||
if ($cgi->{sub_bounced} and $cgi->{sub_bounced} ne '*') {
|
||||
my $opt = $cgi->{'sub_bounced-opt'} || '=';
|
||||
$cond->add(sub_bounced => $opt => $cgi->{sub_bounced});
|
||||
}
|
||||
my $rec = $db->delete($cond);
|
||||
$msg = GList::language('LST_BOUNCED_REMOVED', $rec);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_unsub_bounced} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_unsub_bounced {
|
||||
#--------------------------------------------------------------------
|
||||
# Let you to unsubscribe all bounced users
|
||||
#
|
||||
my $msg = shift;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
my %hash;
|
||||
my $conditions = '';
|
||||
$hash{sub_list_id_fk} = $cgi->{sub_list_id_fk} || '';
|
||||
$conditions .= ";list_id=$cgi->{sub_list_id_fk}" if $cgi->{sub_list_id_fk};
|
||||
|
||||
if ($cgi->{sub_bounced} and $cgi->{sub_bounced} eq '*') {
|
||||
$conditions .= ';sub_bounced=*';
|
||||
$hash{sub_bounced} = 1;
|
||||
$hash{'sub_bounced-opt'} = '>=';
|
||||
}
|
||||
else {
|
||||
$conditions .= ";sub_bounced=$cgi->{sub_bounced}";
|
||||
$conditions .= ";sub_bounced-opt=$cgi->{'sub_bounced-opt'}";
|
||||
if ($cgi->{'sub_bounced-opt'} and $cgi->{'sub_bounced-opt'} eq '<') {
|
||||
$hash{'sub_bounced-lt'} = $cgi->{sub_bounced};
|
||||
$hash{'sub_bounced-ge'} = 1;
|
||||
}
|
||||
elsif ($cgi->{'sub_bounced-opt'} and $cgi->{'sub_bounced-opt'} eq '<=') {
|
||||
$hash{'sub_bounced-le'} = $cgi->{sub_bounced};
|
||||
$hash{'sub_bounced-ge'} = 1;
|
||||
}
|
||||
else {
|
||||
$hash{sub_bounced} = $cgi->{sub_bounced} || 1;
|
||||
$hash{'sub_bounced-opt'} = $cgi->{'sub_bounced-opt'} || '>=';
|
||||
}
|
||||
}
|
||||
my $results = GList::search(
|
||||
cgi => \%hash,
|
||||
db => $DB->table('Subscribers'),
|
||||
prefix => 'sub',
|
||||
sb => 'sub_email',
|
||||
so => 'ASC',
|
||||
return_msg => 'LST_BOUNCED_RESULTS',
|
||||
int_field => 1,
|
||||
);
|
||||
if (ref $results ne 'HASH') {
|
||||
return ('lst_unsub_bounced.html', { msg => $msg || $results });
|
||||
}
|
||||
|
||||
$results->{msg} = $msg if ($msg);
|
||||
return ('lst_unsub_bounced.html', { %$results, conditions => $conditions });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_add} = <<'END_OF_SUB';
|
||||
sub lst_sub_add {
|
||||
#-------------------------------------------------------------------
|
||||
# Add a subscriber
|
||||
#
|
||||
return ('lst_sub_add.html') if ($IN->param('form'));
|
||||
return ('lst_sub_add.html', { msg => GList::language('LST_IPT_LIST_EMPTY') }) if (!$IN->param('import_to'));
|
||||
|
||||
my $import_to = (ref $IN->param('import_to') eq 'ARRAY') ? $IN->param('import_to') : [$IN->param('import_to')];
|
||||
my $email = $IN->param('new_email');
|
||||
my $name = $IN->param('new_name');
|
||||
if ($email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $email =~ /\s/) { # check email address
|
||||
return ('lst_sub_add.html', { msg => GList::language('LST_IPT_INVALID_EMAIL') });
|
||||
}
|
||||
$email = lc $email;
|
||||
|
||||
# Create stoplist database and load wild cards
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
|
||||
# Setup the language for GT::SQL.
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = GList::language('SYS_DUPLICATE');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = GList::language('LST_IMP_NOTNULL') if ( GList::language('LST_IMP_NOTNULL') );
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = '';
|
||||
|
||||
my @results;
|
||||
foreach my $id (@$import_to) {
|
||||
my $info = GList::check_owner('Lists', 'lst', $id);
|
||||
push @results, { sub_email => $email, lst_title => $info->{lst_title}, status => lst_subscribers($info) } if ( ref $info ne 'HASH' );
|
||||
|
||||
push @results, { sub_email => $email, lst_title => $info->{lst_title}, status => '' };
|
||||
my $error = _check_subscriber($email, $info->{lst_id}, $db_stl, $wild_cards);
|
||||
if ($error) {
|
||||
$results[-1]->{status} = $error;
|
||||
}
|
||||
elsif ($db->count({ sub_email => $email, sub_list_id_fk => $id })) {
|
||||
$results[-1]->{status} = GList::language('SYS_DUPLICATE');
|
||||
}
|
||||
else {
|
||||
$db->insert({ sub_email => $email, sub_name => $name, sub_list_id_fk => $id, sub_user_id_fk => $info->{lst_user_id_fk} });
|
||||
}
|
||||
}
|
||||
return ('lst_sub_success.html', { results => \@results, msg => GList::language('LST_SUB_ADDED', $email) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_modify} = <<'END_OF_SUB';
|
||||
sub lst_sub_modify {
|
||||
#-------------------------------------------------------------------
|
||||
# Modify a subscriber
|
||||
#
|
||||
my $sub_id = $IN->param('subid');
|
||||
my $old_data = $DB->table('Lists', 'Subscribers')->select({ sub_id => $sub_id }, [ 'lst_title', 'sub_email as new_email', 'sub_name as new_name', 'sub_validated as new_validated', 'sub_bounced as new_bounced', 'sub_list_id_fk'])->fetchrow_hashref;
|
||||
return lst_subscribers(GList::language('LST_INVALID')) if (!$old_data);
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $old_data->{sub_list_id_fk});
|
||||
return lst_subscribers($info) if (ref $info ne 'HASH');
|
||||
|
||||
return ('lst_sub_modify.html', $old_data) if ($IN->param('form'));
|
||||
|
||||
my $new_email = $IN->param('new_email');
|
||||
my $name = $IN->param('new_name');
|
||||
my $validated = ($IN->param('new_validated')) ? '1' : '0';
|
||||
my $bounced = $IN->param('new_bounced') || 0;
|
||||
|
||||
if ($new_email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $new_email =~ /\s/) { # check email address
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_INVALID_EMAIL'), %$info });
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
if ($DB->table('Subscribers')->count( GT::SQL::Condition->new(
|
||||
sub_email => '=' => $new_email,
|
||||
sub_list_id_fk => '=' => $old_data->{sub_list_id_fk},
|
||||
sub_id => '<>'=> $sub_id,
|
||||
)) == 1 ) {
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_DUPLICATE_EMAIL'), %$info });
|
||||
}
|
||||
else {
|
||||
$DB->table('Subscribers')->update({
|
||||
sub_email => $new_email,
|
||||
sub_name => $name,
|
||||
sub_validated => $validated,
|
||||
sub_bounced => $bounced,
|
||||
}, { sub_id => $sub_id });
|
||||
}
|
||||
return lst_subscribers(GList::language('LST_SUB_MODIFIED', $old_data->{new_email}));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
|
||||
$COMPILE{lst_sub_delete} = <<'END_OF_SUB';
|
||||
sub lst_sub_delete {
|
||||
#-------------------------------------------------------------------
|
||||
# Delete the subscribers
|
||||
#
|
||||
return lst_subscribers(1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_validate} = <<'END_OF_SUB';
|
||||
sub lst_sub_validate {
|
||||
#-------------------------------------------------------------------
|
||||
# Validate the subscribers
|
||||
#
|
||||
return lst_subscribers(2);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_unbounced} = <<'END_OF_SUB';
|
||||
sub lst_sub_unbounced {
|
||||
#-------------------------------------------------------------------
|
||||
# Validate the subscribers
|
||||
#
|
||||
my $action = $IN->param('all') ? 4 : 3;
|
||||
return lst_subscribers($action);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_qsort} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _qsort {
|
||||
#------------------------------------------------------------------
|
||||
my ($list_file, $orderby, $sortdown) = @_;
|
||||
my $sorted;
|
||||
@$sorted =
|
||||
sort {
|
||||
my $da = lc $a->{$orderby}; #lower case
|
||||
my $db = lc $b->{$orderby};
|
||||
my $res;
|
||||
if ($orderby eq 'size' or $orderby eq 'date') {
|
||||
$res = $db <=> $da;
|
||||
}
|
||||
else {
|
||||
$res = $db cmp $da;
|
||||
}
|
||||
if ($res == 0 and $orderby ne 'name') {
|
||||
lc $b->{name} cmp lc $a->{name};
|
||||
}
|
||||
else {
|
||||
$res;
|
||||
}
|
||||
} @$list_file;
|
||||
($sortdown) and @$sorted = reverse @$sorted;
|
||||
return $sorted;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_search_bar} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _search_bar {
|
||||
#---------------------------------------------------------------------
|
||||
# create quick search bar
|
||||
#
|
||||
my ($sth, $url) = @_;
|
||||
my $current = $IN->param('alpha') || '';
|
||||
my @alpha = ('All', 'A'..'Z', '0..9', 'Other');
|
||||
|
||||
my ($search_bar, $items);
|
||||
$items->{All} = 'all';
|
||||
while (my ($letter) = $sth->fetchrow_array) {
|
||||
$letter = uc $letter;
|
||||
if ($letter =~ /\d/) {
|
||||
exists $items->{'0..9'} or $items->{'0..9'} = 'number';
|
||||
}
|
||||
elsif ($letter =~ /[\W_]/) {
|
||||
exists $items->{Other} or $items->{Other} = 'other';
|
||||
}
|
||||
else {
|
||||
exists $items->{$letter} or $items->{$letter} = $letter;
|
||||
}
|
||||
}
|
||||
foreach (@alpha) {
|
||||
if ($_ eq 'All') {
|
||||
$search_bar .= ( (!$current or $current eq 'all') and !$IN->param('bsearch') ) ? "<b>$_</b> " : "<a href='$url&alpha=all'>$_</a> ";
|
||||
}
|
||||
elsif ($items->{$_}) {
|
||||
my $l = ($_ eq '0..9') ? 'number' : lc $_;
|
||||
$search_bar .= ( lc $current eq lc $l ) ? "<b>$_</b> " : "<a href='$url;alpha=$l'>$_</a> ";
|
||||
}
|
||||
else {
|
||||
$search_bar .= "$_ ";
|
||||
}
|
||||
}
|
||||
return $search_bar;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _determine_action {
|
||||
#----------------------------------------------------------------------------
|
||||
# Check valid action
|
||||
#
|
||||
my $action = shift || undef;
|
||||
return if (!$action);
|
||||
return 'lst_home' if ($action eq 'lst_search' );
|
||||
|
||||
my %valid = (
|
||||
map { $_ => 1 } qw(
|
||||
lst_home
|
||||
lst_add
|
||||
lst_modify_form
|
||||
lst_modify
|
||||
lst_search_form
|
||||
lst_delete
|
||||
lst_html
|
||||
lst_import
|
||||
lst_subscribers
|
||||
lst_sub_add
|
||||
lst_sub_modify
|
||||
lst_sub_delete
|
||||
lst_sub_validate
|
||||
lst_sub_unbounced
|
||||
lst_unsub_bounced
|
||||
)
|
||||
);
|
||||
exists $valid{$action} and return $action;
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
|
||||
1076
site/glist/lib/GList/Mailer.pm
Normal file
1076
site/glist/lib/GList/Mailer.pm
Normal file
File diff suppressed because it is too large
Load Diff
1185
site/glist/lib/GList/Message.pm
Normal file
1185
site/glist/lib/GList/Message.pm
Normal file
File diff suppressed because it is too large
Load Diff
167
site/glist/lib/GList/Plugins.pm
Normal file
167
site/glist/lib/GList/Plugins.pm
Normal file
@ -0,0 +1,167 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Plugins.pm,v 1.9 2004/01/13 01:21:56 jagerman 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::Plugins;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use GList qw/$IN $CFG $USER/;
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Plugin config #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub get_plugin_user_cfg {
|
||||
# --------------------------------------------------------------
|
||||
# Returns the user config hash for a given plugin.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return {};
|
||||
(ref $cfg->{$plugin_name}->{user} eq 'ARRAY') or return {};
|
||||
|
||||
my $opts = {};
|
||||
foreach my $opt (@{$cfg->{$plugin_name}->{user}}) {
|
||||
$opts->{$opt->[0]} = $opt->[1];
|
||||
}
|
||||
return $opts;
|
||||
}
|
||||
|
||||
sub set_plugin_user_cfg {
|
||||
# --------------------------------------------------------------
|
||||
# Takes a plugin name and config hash and saves it.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $hash = shift || return;
|
||||
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return;
|
||||
(ref $cfg->{$plugin_name}->{user} eq 'ARRAY') or return {};
|
||||
|
||||
foreach my $opt (@{$cfg->{$plugin_name}->{user}}) {
|
||||
$opt->[1] = $hash->{$opt->[0]};
|
||||
}
|
||||
return GT::Plugins->save_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins', $cfg );
|
||||
}
|
||||
|
||||
sub get_plugin_registry {
|
||||
# --------------------------------------------------------------
|
||||
# Returns the user config hash for a given plugin.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return {};
|
||||
|
||||
return ( $cfg->{$plugin_name}->{registry} || {} );
|
||||
}
|
||||
|
||||
sub set_plugin_registry {
|
||||
# --------------------------------------------------------------
|
||||
# Takes a plugin name and config hash and saves it.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $hash = shift || return;
|
||||
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
|
||||
exists $cfg->{$plugin_name} or return;
|
||||
|
||||
my $registry = ( $cfg->{$plugin_name}->{registry} ||= {} );
|
||||
foreach my $opt ( keys %{$hash} ) {
|
||||
$registry->{$opt} = $hash->{$opt};
|
||||
}
|
||||
|
||||
return GT::Plugins->save_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins', $cfg );
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Displaying #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub manager {
|
||||
# -------------------------------------------------------------------
|
||||
# Manages the plugin installer, basically just creates an installerobject,
|
||||
# and returns the output. Real work is done in GT::Plugins::Installer
|
||||
#
|
||||
|
||||
require GT::Plugins::Manager;
|
||||
my $man = new GT::Plugins::Manager (
|
||||
cgi => $IN,
|
||||
tpl_root => "$CFG->{priv_path}/templates/$CFG->{template_set}",
|
||||
plugin_dir => $CFG->{priv_path} . "/lib/GList/Plugins",
|
||||
prog_name => 'mlist',
|
||||
prog_ver => $CFG->{version},
|
||||
prog_reg => $CFG->{reg_number},
|
||||
prefix => 'GList::Plugins::',
|
||||
base_url => "glist.cgi?do=admin_page&pg=plugin_manager.html".(( $USER->{use_cookie} ) ? '' : "&sid=$USER->{session_id}"),
|
||||
path_to_perl => $CFG->{path_to_perl},
|
||||
perl_args => "-cw -I$CFG->{priv_path}"
|
||||
) or return "Error loading plugin manager: $GT::Plugins::error";
|
||||
return $man->process;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Wizard #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub wizard {
|
||||
# -------------------------------------------------------------------
|
||||
# Manages the plugin wizard, basically just creates a wizard object,
|
||||
# and returns the output. Real work is done in GT::Plugins::Wizard.
|
||||
#
|
||||
require GT::Plugins::Wizard;
|
||||
my $wiz = new GT::Plugins::Wizard (
|
||||
cgi => $IN,
|
||||
tpl_root => "$CFG->{priv_path}/templates/$CFG->{template_set}",
|
||||
plugin_dir => $CFG->{priv_path} . "/lib/GList/Plugins",
|
||||
prog_ver => $CFG->{version},
|
||||
install_header => 'use GList qw/$IN $DB $CFG/;',
|
||||
initial_indent => '',
|
||||
prefix => 'GList::Plugins::',
|
||||
dirs => {
|
||||
user_cgi => '$CFG->{cgi_path}',
|
||||
admin_cgi => '$CFG->{cgi_path}'
|
||||
}
|
||||
);
|
||||
return $wiz->process;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Displaying #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub admin_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Displays the admin menu with the plugin options shown.
|
||||
#
|
||||
require GT::Plugins::Manager;
|
||||
my $man = new GT::Plugins::Manager(
|
||||
cgi => $IN,
|
||||
tpl_root => "$CFG->{priv_path}/templates/$CFG->{template_set}",
|
||||
plugin_dir => $CFG->{priv_path} . "/lib/GList/Plugins",
|
||||
prefix => 'GList::Plugins::',
|
||||
prog_name => 'glist',
|
||||
prog_ver => $CFG->{version},
|
||||
prog_reg => $CFG->{reg_number},
|
||||
base_url => 'glist.cgi?do=admin_page&pg=plugin_manager.html'.(( $USER->{use_cookie} ) ? '' : "&sid=$USER->{session_id}"),
|
||||
path_to_perl => $CFG->{path_to_perl},
|
||||
perl_args => "-cw -I$CFG->{priv_path}"
|
||||
);
|
||||
return { menu => $man->admin_menu, cgi_url => $CFG->{cgi_url} };
|
||||
}
|
||||
1;
|
||||
|
||||
103
site/glist/lib/GList/Plugins/SubscribersMod.pm
Normal file
103
site/glist/lib/GList/Plugins/SubscribersMod.pm
Normal file
@ -0,0 +1,103 @@
|
||||
# ==================================================================
|
||||
# GList::Plugins::SubscribersMod - Auto Generated Program Module
|
||||
#
|
||||
# GList::Plugins::SubscribersMod
|
||||
# Author : Virginia Lo
|
||||
# Version : 1
|
||||
# Updated : Wed Jun 4 12:24:28 2008
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package GList::Plugins::SubscribersMod;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use GT::Plugins qw/STOP CONTINUE/;
|
||||
use GList qw/$IN $DB $CFG/;
|
||||
|
||||
# Inherit from base class for debug and error methods
|
||||
@GList::Plugins::SubscribersMod::ISA = qw(GT::Base);
|
||||
|
||||
# Your code begins here.
|
||||
|
||||
|
||||
# PLUGIN HOOKS
|
||||
# ===================================================================
|
||||
|
||||
|
||||
sub lst_sub_modify {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This subroutine will be called whenever the hook 'lst_sub_modify' is run. You
|
||||
# should call GT::Plugins->action(STOP) if you don't want the regular
|
||||
# 'lst_sub_modify' code to run, otherwise the code will continue as normal.
|
||||
#
|
||||
my (@args) = @_;
|
||||
|
||||
# Do something useful here
|
||||
GT::Plugins->action(STOP);
|
||||
|
||||
my $sub_id = $IN->param('subid');
|
||||
my $old_data = $DB->table('Lists', 'Subscribers')->select({ sub_id => $sub_id }, [ 'lst_title', 'sub_email as new_email', 'sub_name as new_name', 'sub_validated as new_validated', 'sub_bounced as new_bounced', 'sub_list_id_fk', 'Subscribers.*'])->fetchrow_hashref;
|
||||
return lst_subscribers(GList::language('LST_INVALID')) if (!$old_data);
|
||||
|
||||
my $cols = $DB->table('Subscribers')->cols;
|
||||
foreach (keys %$cols) {
|
||||
next if ($_ eq 'sub_created' or $_ eq 'sub_id' or $_ eq 'sub_user_id_fk' or $_ eq 'sub_list_id_fk' or $_ eq 'sub_val_code');
|
||||
my $key = $_;
|
||||
$key =~ s/sub_/new_/g;
|
||||
$old_data->{$key} ||= $old_data->{$_};
|
||||
delete $old_data->{$_};
|
||||
}
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $old_data->{sub_list_id_fk});
|
||||
return lst_subscribers($info) if (ref $info ne 'HASH');
|
||||
|
||||
return ('lst_sub_modify.html', $old_data) if ($IN->param('form'));
|
||||
|
||||
my $new_email = $IN->param('new_email');
|
||||
my $name = $IN->param('new_name');
|
||||
my $validated = ($IN->param('new_validated')) ? '1' : '0';
|
||||
my $bounced = $IN->param('new_bounced') || 0;
|
||||
|
||||
if ($new_email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $new_email =~ /\s/) { # check email address
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_INVALID_EMAIL'), %$info });
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
if ($DB->table('Subscribers')->count( GT::SQL::Condition->new(
|
||||
sub_email => '=' => $new_email,
|
||||
sub_list_id_fk => '=' => $old_data->{sub_list_id_fk},
|
||||
sub_id => '<>'=> $sub_id,
|
||||
)) == 1 ) {
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_DUPLICATE_EMAIL'), %$info });
|
||||
}
|
||||
else {
|
||||
my $update = {
|
||||
sub_email => $new_email,
|
||||
sub_name => $name,
|
||||
sub_validated => $validated,
|
||||
sub_bounced => $bounced,
|
||||
};
|
||||
foreach (keys %$cols) {
|
||||
my $key = $_;
|
||||
$key =~ s/sub_/new_/g;
|
||||
if ($IN->param($key)) {
|
||||
$update->{$_} ||= $IN->param($key);
|
||||
}
|
||||
}
|
||||
#use Data::Dumper; print $IN->header . "<pre>".Dumper($old_data,$update)."</pre>";
|
||||
$DB->table('Subscribers')->update({
|
||||
%$update
|
||||
}, { sub_id => $sub_id });
|
||||
}
|
||||
require GList::List;
|
||||
return GList::List::lst_subscribers(GList::language('LST_SUB_MODIFIED', $old_data->{new_email}));
|
||||
|
||||
|
||||
return @args;
|
||||
}
|
||||
|
||||
# Always end with a 1.
|
||||
1;
|
||||
393
site/glist/lib/GList/Profile.pm
Normal file
393
site/glist/lib/GList/Profile.pm
Normal file
@ -0,0 +1,393 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Profile.pm,v 1.39 2004/10/14 22:57:54 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::Profile;
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects :user_type $DEBUG/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
sub process {
|
||||
#--------------------------------------------------
|
||||
# Determine what to do
|
||||
#
|
||||
my $do = $IN->param('do') || '';
|
||||
my $action = _determine_action($do) or die "Error: Invalid Action! ($do)";
|
||||
my ($tpl, $results) = GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action);
|
||||
|
||||
if ($tpl) {
|
||||
my $hidden = GList::hidden();
|
||||
$results->{hidden_query} = $hidden->{hidden_query};
|
||||
$results->{hidden_objects} = $hidden->{hidden_objects};
|
||||
GList::display($tpl, $results);
|
||||
}
|
||||
}
|
||||
|
||||
$COMPILE{pro_profile} = <<'END_OF_SUB';
|
||||
sub pro_profile {
|
||||
#-------------------------------------------------------------------------
|
||||
# print account information
|
||||
#
|
||||
my $msg = shift;
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $info = $db->get($USER->{usr_username});
|
||||
my $cols = $db->cols();
|
||||
|
||||
my $hsh = {};
|
||||
foreach (keys %$cols) {
|
||||
$hsh->{"mod_$_"} = $info->{$_};
|
||||
}
|
||||
my $pg = ($IN->param('pro_mailing')) ? 'pro_mailing.html' : 'pro_profile.html';
|
||||
return ($pg, { msg => $msg, %$hsh });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_update} = <<'END_OF_SUB';
|
||||
sub pro_update {
|
||||
#---------------------------------------------------------
|
||||
# Update account information
|
||||
#
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $cols = $db->cols();
|
||||
my $cgi = $IN->get_hash();
|
||||
my %restricted_field = (
|
||||
usr_username => 1,
|
||||
usr_password => 1,
|
||||
usr_status => 1,
|
||||
usr_type => 1,
|
||||
usr_limit_list => 1,
|
||||
usr_limit_sublist=> 1,
|
||||
usr_limit_email30=> 1,
|
||||
usr_validate_code=> 1
|
||||
);
|
||||
|
||||
my $hsh;
|
||||
foreach (keys %$cols) {
|
||||
next if (exists $restricted_field{$_});
|
||||
$hsh->{$_} = $cgi->{"mod_$_"} if (exists $cgi->{"mod_$_"});
|
||||
}
|
||||
|
||||
$hsh->{usr_date_format} = $IN->param('date_preview') if ($IN->param('date_preview'));
|
||||
$hsh->{usr_date_format}||= "%yyyy%-%mm%-%dd%";
|
||||
$hsh->{usr_username} = $USER->{usr_username};
|
||||
$hsh->{usr_updated} = '1';
|
||||
if ($db->modify($hsh)) {
|
||||
my $msg = ($cgi->{pro_mailing}) ? GList::language('USR_TPL_UPDATED') : GList::language('USR_UPDATED', $USER->{usr_username});
|
||||
return pro_profile($msg);
|
||||
}
|
||||
else {
|
||||
local $^W;
|
||||
return pro_profile("<font color=red><b>$GT::SQL::error</b></font>");
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_password} = <<'END_OF_SUB';
|
||||
sub pro_password {
|
||||
#---------------------------------------------------------
|
||||
# Update the new password
|
||||
#
|
||||
return ('pro_password_form.html') if ($IN->param('form'));
|
||||
#------------demo code-----------
|
||||
|
||||
my $old = $IN->param('old_pass');
|
||||
my $new = $IN->param('new_pass');
|
||||
my $con = $IN->param('con_pass');
|
||||
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_PWD_ERR') }) if (!$old or !$new or !$con);
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_PWD_NOT_MATCH') }) if ($new ne $con);
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_PWD_INVALID') }) if ($new ne $con or length $new < 4);
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $user = $db->get($USER->{usr_username});
|
||||
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_OLDPWD_ERR') }) if ($user->{usr_password} ne GList::encrypt($old, $user->{usr_password}));
|
||||
my $crypted = GList::encrypt($new);
|
||||
if ($db->update({ usr_password => $crypted }, { usr_username => $USER->{usr_username} })) {
|
||||
if ($USER->{usr_type} == ADMINISTRATOR and exists $CFG->{admin}->{$USER->{usr_username}}) { # Update new password in Data.pm
|
||||
$CFG->{admin}->{$USER->{usr_username}}->[0] = $crypted;
|
||||
$CFG->save();
|
||||
}
|
||||
return pro_profile(GList::language('ADM_PWD_CHANGED'));
|
||||
}
|
||||
else {
|
||||
local $^W;
|
||||
return ('pro_password_form.html', { msg => "<font color=red><b>$GT::SQL::error</b></font>" });
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_report} = <<'END_OF_SUB';
|
||||
sub pro_report {
|
||||
#-----------------------------------------------------------
|
||||
# Build report
|
||||
#
|
||||
return ('pro_report_form.html') if ($IN->param('form'));
|
||||
|
||||
my $id = $IN->param('id');
|
||||
if ($USER->{usr_type} != ADMINISTRATOR) {
|
||||
return _report_details($USER->{usr_username});
|
||||
}
|
||||
elsif ($USER->{usr_type} == ADMINISTRATOR and $IN->param('d')) { # Show the details reports
|
||||
my $info = $DB->table('Users')->get($id);
|
||||
return ('pro_report.html', { msg => GList::language('RPT_NOT_FOUND', $id) }) if (!$info);
|
||||
return _report_details($id);
|
||||
}
|
||||
my ($from, $to, $mm, $yy, $msg, $url, $toolbar_query);
|
||||
my $date_format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
my @items = ('date_to', 'date_from');
|
||||
|
||||
# Create url
|
||||
foreach (@items) {
|
||||
$url .= "&$_=".$IN->param($_) if ($IN->param($_));
|
||||
}
|
||||
|
||||
if ($IN->param('date_from') or $IN->param('date_to')) {
|
||||
require GT::Date;
|
||||
my $date_from = $IN->param('date_from');
|
||||
my $date_to = $IN->param('date_to');
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
if ($date_from) {
|
||||
$toolbar_query .= "date_from=$date_from;";
|
||||
$valid_from = GList::date_to_time($date_from, $date_format);
|
||||
$date_from = GT::Date::date_get($valid_from, $date_format) if ($valid_from);
|
||||
}
|
||||
if ($date_to) {
|
||||
$toolbar_query .= "date_to=$date_to;";
|
||||
$valid_to = GList::date_to_time($date_to, $date_format);
|
||||
$date_to = GT::Date::date_get($valid_to, $date_format) if ($valid_to);
|
||||
}
|
||||
if (!$valid_from or !$valid_to) {
|
||||
$date_format =~ s/\%//g;
|
||||
return ('pro_report_form.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')) });
|
||||
}
|
||||
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format($date_from, $date_format));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format($date_to.' 23:59:59', "$date_format %hh%:%MM%:%ss%"));
|
||||
$msg = GList::language('RPT_CUS_FROM', $date_from)
|
||||
. ($IN->param('date_to') ? GList::language('RPT_CUS_TO', $date_to) : '')
|
||||
. '</b></font>';
|
||||
}
|
||||
else {
|
||||
($from, $to) = _period_time();
|
||||
($mm, $yy) = _period_time(1);
|
||||
$toolbar_query .= "month=".$IN->param('month').";" if ($IN->param('month'));
|
||||
$toolbar_query .= "year=".$IN->param('year').";" if ($IN->param('year'));
|
||||
if ($IN->param('month') or $IN->param('year') or !defined $IN->param('flag')) {
|
||||
$msg = GList::language('RPT_SUMARY'). (( $IN->param('flag') and !$IN->param('month') ) ? '' : "$mm/");
|
||||
$msg .= ( $IN->param('flag') and !$IN->param('month') ) ? $IN->param('year') : "$yy</b>";
|
||||
$url .= (( $IN->param('flag') and !$IN->param('month') ) ? '' : "&month=$mm"). "&year=$yy";
|
||||
}
|
||||
else {
|
||||
$msg = GList::language('RPT_TITLE2');
|
||||
}
|
||||
}
|
||||
|
||||
# Load database object
|
||||
require GT::SQL::Condition;
|
||||
my $db = $DB->table('MailingIndex');
|
||||
my $cd = new GT::SQL::Condition('mli_done', '>=', $from, 'mli_done', '<=', $to);
|
||||
$db->select_options('GROUP BY mli_user_id_fk ORDER BY mli_user_id_fk');
|
||||
$cd->add('mli_user_id_fk', 'like', "%$id%") if ( $id );
|
||||
|
||||
my $sth = $db->select($cd, ['mli_user_id_fk as email', 'count(mli_id) as sent']);
|
||||
my $hsh = {};
|
||||
while (my ($id, $sent) = $sth->fetchrow_array) {
|
||||
$hsh->{$id} += $sent;
|
||||
}
|
||||
|
||||
# Get user listings
|
||||
my $db_usr = $DB->table('Users');
|
||||
my $cd_usr = new GT::SQL::Condition();
|
||||
my $sb = $IN->param('sb') || 'usr_username';
|
||||
my $so = $IN->param('so') || 'ASC';
|
||||
$cd_usr->add('usr_username', 'like', "%$id%") if ( $id );
|
||||
|
||||
my $mh = $IN->param('mh') || 25;
|
||||
my $nh = $IN->param('nh') || 1;
|
||||
my $ns = ($nh == 1) ? 0 : ( $nh - 1 ) * $mh;
|
||||
|
||||
$db_usr->select_options("ORDER BY usr_type desc, $sb $so", "LIMIT $ns, $mh");
|
||||
my $users = $db_usr->select($cd_usr);
|
||||
my $hits = $db_usr->hits;
|
||||
return ('pro_report.html', { msg => GList::language('RPT_NO_RESULT') }) if ($hits == 0);
|
||||
|
||||
my @output;
|
||||
while ( my $rs = $users->fetchrow_hashref ) {
|
||||
$rs->{sent} = $hsh->{$rs->{usr_username}} if ($hsh->{$rs->{usr_username}});
|
||||
push @output, $rs;
|
||||
}
|
||||
|
||||
return ('pro_report.html', {
|
||||
msg => $msg,
|
||||
results => \@output,
|
||||
hits => $hits,
|
||||
mh => $mh,
|
||||
nh => $nh,
|
||||
url => $url,
|
||||
toolbar_query => $toolbar_query,
|
||||
});
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_report_details} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _report_details {
|
||||
#-----------------------------------------------------------
|
||||
# Build report details
|
||||
#
|
||||
my $id = shift;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
my $db = $DB->table('MailingIndex', 'EmailMailings');
|
||||
my $cd = new GT::SQL::Condition(mli_user_id_fk => '=' => $id, eml_sent => '<>' => 0);
|
||||
my $mh = $cgi->{mh} || 25;
|
||||
my $nh = $cgi->{nh} || 1;
|
||||
my $sb = $cgi->{sb} || 'mli_id';
|
||||
my $so = $cgi->{so} || 'DESC';
|
||||
my $ns = ( $nh == 1 ) ? 0 : ( $nh - 1 ) * $mh;
|
||||
|
||||
my $date_format = $USER->{usr_date_format} || '%mm%-%dd%-%yyyy%';
|
||||
|
||||
my $query = "id=$id;d=1;";
|
||||
my ($period, $mm, $yy, $from, $to);
|
||||
if ($cgi->{date_from} or $cgi->{date_to}) { # Searching by date
|
||||
require GT::Date;
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
my $date_from = $cgi->{date_from};
|
||||
my $date_to = $cgi->{date_to};
|
||||
|
||||
if ($date_from) {
|
||||
$query .= "date_from=$cgi->{date_from};";
|
||||
$period = " from <b>$cgi->{date_from}</b>";
|
||||
$valid_from = GList::date_to_time($cgi->{date_from}, $date_format);
|
||||
$date_from = GT::Date::date_get($valid_from, $date_format) if ($valid_from);
|
||||
}
|
||||
if ($date_to) {
|
||||
$query .= "date_to=$cgi->{date_to};";
|
||||
$period .= " to <b>$cgi->{date_to}";
|
||||
$valid_to = GList::date_to_time($date_to, $date_format);
|
||||
$date_to = GT::Date::date_get($valid_to, $date_format) if ($valid_to);
|
||||
}
|
||||
|
||||
if (!$valid_from or !$valid_to) {
|
||||
$date_format =~ s/\%//g;
|
||||
return ('pro_report_form.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')) });
|
||||
}
|
||||
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format($date_from, $date_format));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format($date_to.' 23:59:59', "$date_format %hh%:%MM%:%ss%"));
|
||||
}
|
||||
else {
|
||||
($from, $to) = _period_time();
|
||||
($mm, $yy) = _period_time(1);
|
||||
$period = (( $cgi->{month} ) ? "$cgi->{month}/$cgi->{year}" : $cgi->{year});
|
||||
$query .= "month=$cgi->{month};" if ($cgi->{month});
|
||||
$query .= "year=$cgi->{year};" if ($cgi->{year});
|
||||
}
|
||||
require GT::SQL::Condition;
|
||||
$cd->new('mli_done', '>=', $from, 'mli_done', '<=', $to);
|
||||
|
||||
$db->select_options("GROUP BY mli_id, mli_subject, mli_done ORDER BY $sb $so");
|
||||
$db->select($cd, ['mli_id', 'mli_subject', 'mli_done', 'count(eml_mailing_id_fk) as "sent"']);
|
||||
my $hits = $db->hits;
|
||||
return ('pro_report.html', { msg => GList::language('RPT_NO_RESULT') }) if ($hits == 0);
|
||||
|
||||
$db->select_options("GROUP BY mli_id, mli_subject, mli_done ORDER BY $sb $so", "LIMIT $ns, $mh");
|
||||
my $results = $db->select($cd, ['mli_id', 'mli_subject', 'mli_done', 'count(eml_mailing_id_fk) as "sent"'])->fetchall_hashref or die $GT::SQL::error;
|
||||
my ($total) = $db->select($cd, ['count(*) as total'])->fetchrow_array;
|
||||
my $msg = ( $period ) ? GList::language('RPT_TITLE', $period) : GList::language('RPT_TITLE2');
|
||||
return ('pro_report.html', {
|
||||
msg => $msg,
|
||||
results => $results,
|
||||
hits => $hits,
|
||||
mh => $mh,
|
||||
nh => $nh,
|
||||
url => "month=$mm;year=$yy;id=$id;d=1",
|
||||
total_recipients => $total,
|
||||
toolbar_query => $query
|
||||
});
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_template} = <<'END_OF_SUB';
|
||||
sub pro_template {
|
||||
#-------------------------------------------------------------------------
|
||||
# Edit the email template
|
||||
#
|
||||
return ('pro_template.html');
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_period_time} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _period_time {
|
||||
#--------------------------------------------------------------------
|
||||
# Convert a date to unix time
|
||||
#
|
||||
my $type = shift;
|
||||
require GT::Date;
|
||||
require GT::SQL::Condition;
|
||||
my ($from, $to);
|
||||
my $mm = $IN->param('month') || GT::Date::date_get(time, '%mm%');
|
||||
my $yy = $IN->param('year') || GT::Date::date_get(time, '%yyyy%');
|
||||
return ($mm, $yy) if (defined $type and $type == 1);
|
||||
|
||||
if (!$IN->param('month') and $IN->param('flag')) {
|
||||
$type = 2;
|
||||
}
|
||||
|
||||
if ( !$type ) {
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format("$yy-$mm-01", '%yyyy%-%mm%-%dd%'));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format("$yy-$mm-30 00:00:00", '%yyyy%-%mm%-%dd% %hh%:%MM%:%ss%'));
|
||||
}
|
||||
else {
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format("$yy-01-01", '%yyyy%-%mm%-%dd%'));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format("$yy-12-31 23:59:59", '%yyyy%-%mm%-%dd% %hh%:%MM%:%ss%'));
|
||||
}
|
||||
return ($from, $to);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _determine_action {
|
||||
#----------------------------------------------------------------------------
|
||||
# Check valid action
|
||||
#
|
||||
my $action = shift || undef;
|
||||
if ( $action =~ /pro_report/ ) {
|
||||
$MN_SELECTED = 4;
|
||||
}
|
||||
else {
|
||||
$MN_SELECTED = 5;
|
||||
}
|
||||
return if ( !$action );
|
||||
|
||||
my %valid = (
|
||||
map { $_ => 1 } qw(
|
||||
pro_profile
|
||||
pro_update
|
||||
pro_password
|
||||
pro_report
|
||||
pro_template
|
||||
)
|
||||
);
|
||||
exists $valid{$action} and return $action;
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
448
site/glist/lib/GList/SQL.pm
Normal file
448
site/glist/lib/GList/SQL.pm
Normal file
@ -0,0 +1,448 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: SQL.pm,v 1.40 2004/10/05 22:02:27 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::SQL;
|
||||
|
||||
use strict;
|
||||
use vars qw/@TABLES $EMAIL_RE/;
|
||||
use GList qw/$DB $CFG/;
|
||||
|
||||
@TABLES = qw/Users Users_Sessions EmailTemplates Messages Lists Subscribers
|
||||
MailingIndex EmailMailings CatMessages CatMailing MessageAttachments
|
||||
MailingAttachments StopLists/;
|
||||
|
||||
$EMAIL_RE = '.@\S+\.\S+$';
|
||||
|
||||
# Index naming format:
|
||||
#
|
||||
# a_bcd[_q]
|
||||
#
|
||||
# Where "a" is (usually) the capital letters from the table name (i.e. EmailTemplates gets "et"),
|
||||
# except for CatMailing, which is cml, and MailingAttachments, which is mla.
|
||||
#
|
||||
# b,c,d,... correspond to the following:
|
||||
#
|
||||
# b - sub_bounced
|
||||
# c - *_cat_id_fk | eml_code
|
||||
# d - session_date | mli_delete
|
||||
# e - usr_email | sub_email | stl_email
|
||||
# l - *_list_id_fk
|
||||
# m - *_message_id_fk
|
||||
# n - tpl_name | mli_done
|
||||
# t - lst_title
|
||||
# u - *_user_id_fk
|
||||
# v - sub_validated
|
||||
#
|
||||
# Finally, the optional "_q" is used for unique indices.
|
||||
#
|
||||
|
||||
sub tables {
|
||||
#----------------------------------------------------------------
|
||||
# Defines the SQL tables
|
||||
#
|
||||
my $action = shift || 'warn';
|
||||
my $output = '';
|
||||
|
||||
#---------- Users Table -----------------
|
||||
create_table(\$output, 'Users', $action,
|
||||
cols => [
|
||||
usr_username => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User Name' },
|
||||
usr_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Email Address', form_regex => $EMAIL_RE },
|
||||
usr_password => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Password' },
|
||||
usr_type => { type => 'TINYINT', not_null => 1, default => 1, form_display => 'Type' },
|
||||
usr_reply_email => { type => 'CHAR', size => 100, not_null => 0, form_display => 'Reply to Email', form_regex => $EMAIL_RE },
|
||||
usr_bounce_email => { type => 'CHAR', size => 100, not_null => 0, form_display => 'Bounce Email', form_regex => $EMAIL_RE },
|
||||
usr_date_format => { type => 'CHAR', size => 50, form_display => 'Date Format' },
|
||||
usr_compose_mode => { type => 'CHAR', size => 5, form_display => 'Editor Advanced', default => 'text' },
|
||||
usr_editor_advanced => { type => 'TINYINT', not_null => 1, default => 0 },
|
||||
usr_status => { type => 'TINYINT', default => '1', form_display => 'Status' },
|
||||
usr_limit_list => { type => 'INT', default => '0', form_display => 'Limit Number of List' },
|
||||
usr_limit_sublist => { type => 'INT', default => '0', form_display => 'Limit Number of subscriber per List' },
|
||||
usr_limit_email30 => { type => 'INT', default => '0', form_display => 'Limit Number of Email Sending in The Last 30 days' },
|
||||
usr_mail_host => { type => 'CHAR', size => 100, form_display => 'Server Mail hostname' },
|
||||
usr_mail_port => { type => 'CHAR', size => 3, form_display => 'Server Mail port' },
|
||||
usr_mail_account => { type => 'CHAR', size => 50, form_display => 'Mail Account' },
|
||||
usr_mail_password => { type => 'CHAR', size => 20, form_display => 'Mail Password' },
|
||||
usr_validate_code => { type => 'CHAR', size => 32, binary => 1, form_display => 'Validate Code' },
|
||||
usr_updated => { type => 'TINYINT', default => '0', form_display => 'Account Updated' },
|
||||
usr_header_html => { type => 'TEXT', default => '', form_display => 'Mailing Header' },
|
||||
usr_header_text => { type => 'TEXT', default => '', form_display => 'Mailing Header' },
|
||||
usr_footer_html => { type => 'TEXT', default => '', form_display => 'Mailing Footer' },
|
||||
usr_footer_text => { type => 'TEXT', default => '', form_display => 'Mailing Footer' },
|
||||
pro_first_name => { type => 'CHAR', size => 20, not_null => 1, form_display => 'First Name', form_size => '35' },
|
||||
pro_last_name => { type => 'CHAR', size => 30, not_null => 1, form_display => 'Last Name', form_size => '35' },
|
||||
pro_company => { type => 'CHAR', size => 100, form_display => 'Company Name', form_size => '35' },
|
||||
pro_url => { type => 'CHAR', size => 255, form_display => 'URL', form_size => '35' },
|
||||
],
|
||||
pk => 'usr_username',
|
||||
unique => {
|
||||
u_e_q => ['usr_email']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- Users_Sessions Table -----------------
|
||||
create_table(\$output, 'Users_Sessions', $action,
|
||||
cols => [
|
||||
session_id => { type => 'CHAR', binary => 1, size => 32, not_null => 1 },
|
||||
session_user_id => { type => 'CHAR', size => 50 },
|
||||
session_date => { type => 'INT', not_null => 1 },
|
||||
session_data => { type => 'TEXT' }
|
||||
],
|
||||
pk => 'session_id',
|
||||
fk => {
|
||||
Users => { session_user_id => 'usr_username' }
|
||||
},
|
||||
index => {
|
||||
us_d => ['session_date']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- EmailTemplates Table -----------------
|
||||
create_table(\$output, 'EmailTemplates', $action,
|
||||
cols => [
|
||||
tpl_id => { type => 'INT', not_null=> 1, form_display => 'ID' },
|
||||
tpl_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User Name' },
|
||||
tpl_name => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Template Name' },
|
||||
tpl_to => { type => 'CHAR', size => 50, not_null => 1, form_display => 'To' },
|
||||
tpl_subject => { type => 'CHAR', size => 100,not_null => 1, form_display => 'Subject' },
|
||||
tpl_from => { type => 'CHAR', size => 100,not_null => 1, form_display => 'From' },
|
||||
tpl_extra => { type => 'CHAR', size => 255, form_display => 'Extra Header' },
|
||||
tpl_body => { type => 'TEXT', not_null=> 1, form_display => 'Email Body' },
|
||||
],
|
||||
pk => 'tpl_id',
|
||||
ai => 'tpl_id',
|
||||
|
||||
unique => {
|
||||
et_un_q => [qw/tpl_user_id_fk tpl_name/]
|
||||
},
|
||||
fk => { Users => { tpl_user_id_fk => 'usr_username' } }
|
||||
);
|
||||
|
||||
#---------- CatMessages Table -----------------
|
||||
create_table(\$output, 'CatMessages', $action,
|
||||
cols => [
|
||||
cms_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
cms_name => { type => 'CHAR', not_null => 1, size => 30, form_display => 'Folder Name' },
|
||||
cms_user_id_fk => { type => 'CHAR', not_null => 1, size => 50, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'cms_id',
|
||||
ai => 'cms_id',
|
||||
index => {
|
||||
cm_u => ['cms_user_id_fk']
|
||||
},
|
||||
fk => { Users => { cms_user_id_fk => 'usr_username' } }
|
||||
);
|
||||
|
||||
#---------- Messages Table -----------------
|
||||
create_table(\$output, 'Messages', $action,
|
||||
cols => [
|
||||
msg_id => { type => 'INT', not_null => 1, form_display => 'Message ID' },
|
||||
msg_mode => { type => 'CHAR', size => 5, default => 'text', form_display => 'Message Mode' },
|
||||
msg_charset => { type => 'CHAR', size => 15, not_null => 1, default => 'us-ascii', form_display => 'Charset'},
|
||||
msg_subject => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Subject', 'weight' => '1' },
|
||||
msg_from_name => { type => 'CHAR', size => 70, form_display => 'From Name' },
|
||||
msg_from_email => { type => 'CHAR', size => 100, not_null => 1, form_display => 'From Email', form_regex => $EMAIL_RE },
|
||||
msg_reply_to => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Reply to Email', form_regex => $EMAIL_RE },
|
||||
msg_bounce_email => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Bounce Email', form_regex => $EMAIL_RE },
|
||||
msg_created => { type => 'INT', form_display => 'Name' },
|
||||
msg_content_text => { type => 'LONGTEXT', form_display => 'TEXT Content', 'weight' => '1' },
|
||||
msg_content_html => { type => 'LONGTEXT', form_display => 'HTML Content', 'weight' => '1' },
|
||||
msg_cat_id_fk => { type => 'INT', default => 0, not_null => 1, form_display => 'Category ID' },
|
||||
msg_status => { type => 'TINYINT', default => 0, form_display => 'Status' },
|
||||
msg_track_open => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of Users opening this message' },
|
||||
msg_track_click => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of Clicks' },
|
||||
msg_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'msg_id',
|
||||
ai => 'msg_id',
|
||||
fk => {
|
||||
Users => { msg_user_id_fk => 'usr_username' },
|
||||
CatMessages => { msg_cat_id_fk => 'cms_id' }
|
||||
},
|
||||
index => {
|
||||
m_uc => [qw/msg_user_id_fk msg_cat_id_fk/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- MessageAttachments Table -----------------
|
||||
create_table(\$output, 'MessageAttachments', $action,
|
||||
cols => [
|
||||
att_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
att_message_id_fk => { type => 'INT', not_null => 1, form_display => 'Campaign ID' },
|
||||
att_file_name => { type => 'CHAR', size => 255, form_display => 'File Name' },
|
||||
att_file_size => { type => 'INT', form_display => 'File Size' },
|
||||
],
|
||||
pk => 'att_id',
|
||||
ai => 'att_id',
|
||||
fk => { Messages => { att_message_id_fk => 'msg_id' } },
|
||||
index => {
|
||||
ma_m => ['att_message_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- Lists Table -----------------
|
||||
create_table(\$output, 'Lists', $action,
|
||||
cols => [
|
||||
lst_id => { type => 'INT', not_null => 1, form_display => 'List ID' },
|
||||
lst_title => { type => 'CHAR', size => 50, not_null => 1, form_display => 'List Name', weight => '1' },
|
||||
lst_description => { type => 'TEXT', form_display => 'Name', weight => '1' },
|
||||
lst_opt => { type => 'TINYINT', form_display => 'Double Opt In', default => '0' },
|
||||
lst_opt_template => { type => 'CHAR', size => 50, form_display => 'Opt In Template' },
|
||||
lst_subs_template => { type => 'CHAR', size => 50, form_display => 'Subscriber Template' },
|
||||
lst_unsubs_template => { type => 'CHAR', size => 50, form_display => 'Unsubscriber Template' },
|
||||
lst_date_created => { type => 'INT', form_display => 'Created' },
|
||||
lst_url_subscribe_success => { type => 'CHAR', size => 255, form_display => 'Success Subscribe URL' },
|
||||
lst_url_validate_success => { type => 'CHAR', size => 255, form_display => 'Success Validate URL' },
|
||||
lst_url_unsubscribe_success => { type => 'CHAR', size => 255, form_display => 'Success Unsubscribe URL' },
|
||||
lst_url_subscribe_failure => { type => 'CHAR', size => 255, form_display => 'Failure Subscribe URL' },
|
||||
lst_url_unsubscribe_failure => { type => 'CHAR', size => 255, form_display => 'Failure Unsubscribe URL' },
|
||||
lst_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'lst_id',
|
||||
ai => 'lst_id',
|
||||
fk => { Users => { lst_user_id_fk => 'usr_username' } },
|
||||
index => {
|
||||
l_ut => [qw/lst_user_id_fk lst_title/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- Subscribers Table -----------------
|
||||
create_table(\$output, 'Subscribers', $action,
|
||||
cols => [
|
||||
sub_id => { type => 'INT', not_null => 1, form_display => 'Subscriber ID' },
|
||||
sub_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Subscriber Email', form_regex => $EMAIL_RE, weight => '1' },
|
||||
sub_name => { type => 'CHAR', size => 50, form_display => 'Subscriber Name', weight => '1' },
|
||||
sub_created => { type => 'INT', form_display => 'Created' },
|
||||
sub_list_id_fk => { type => 'INT', not_null => 1, form_display => 'List ID' },
|
||||
sub_validated => { type => 'TINYINT', not_null => 1, default => 1, form_display => 'Validated' },
|
||||
sub_val_code => { type => 'CHAR', size => 50, form_display => 'Validation Code' },
|
||||
sub_bounced => { type => 'INT', not_null => 1, default => 0, form_display => 'Bounced Email' },
|
||||
sub_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' },
|
||||
],
|
||||
|
||||
pk => 'sub_id',
|
||||
ai => 'sub_id',
|
||||
fk => {
|
||||
Lists => { sub_list_id_fk => 'lst_id' },
|
||||
Users => { sub_user_id_fk => 'usr_username' }
|
||||
},
|
||||
index => {
|
||||
s_lb => [qw/sub_list_id_fk sub_bounced/],
|
||||
s_lvb => [qw/sub_list_id_fk sub_validated sub_bounced/],
|
||||
s_ue => [qw/sub_user_id_fk sub_email/],
|
||||
s_e => [qw/sub_email/]
|
||||
},
|
||||
unique => {
|
||||
s_le_q => [qw/sub_list_id_fk sub_email/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- CatMailing Table -----------------
|
||||
create_table(\$output, 'CatMailing', $action,
|
||||
cols => [
|
||||
cm_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
cm_name => { type => 'CHAR', not_null => 1, size => 30, form_display => 'Folder Name' },
|
||||
cm_type => { type => 'TINYINT', default => '1', form_display => 'Type' },
|
||||
cm_user_id_fk => { type => 'CHAR', not_null => 1, size => 50, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'cm_id',
|
||||
ai => 'cm_id',
|
||||
fk => { Users => { cm_user_id_fk => 'usr_username' } },
|
||||
index => {
|
||||
cml_u => ['cm_user_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- MailingIndex Table -----------------
|
||||
create_table(\$output, 'MailingIndex', $action,
|
||||
cols => [
|
||||
mli_id => { type => 'INT', not_null => 1, form_display => 'Mailing ID' },
|
||||
mli_done => { type => 'INT', default => 0, form_display => 'Done' },
|
||||
mli_from => { type => 'CHAR', size => 100, form_display => 'From Email', form_regex => $EMAIL_RE },
|
||||
mli_name => { type => 'CHAR', size => 50, form_display => 'From Name' },
|
||||
mli_reply_to => { type => 'CHAR', size => 100, form_display => 'Reply To Email', form_regex => $EMAIL_RE },
|
||||
mli_bounce_email => { type => 'CHAR', size => 100, form_display => 'Bounce Email', form_regex => $EMAIL_RE },
|
||||
mli_charset => { type => 'CHAR', size => 15, not_null => 1, default => 'us-ascii', form_display => 'Charset'},
|
||||
mli_subject => { type => 'CHAR', size => 100, form_display => 'Subject', 'weight' => '1' },
|
||||
mli_message_text => { type => 'LONGTEXT', form_display => 'TEXT Message', 'weight' => '1' },
|
||||
mli_message_html => { type => 'LONGTEXT', form_display => 'HTML Message', 'weight' => '1' },
|
||||
mli_cat_id_fk => { type => 'INT', not_null => 1, default => 0, form_display => 'Category ID' },
|
||||
mli_delete => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Delete' },
|
||||
mli_track_open => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of Users opening this message' },
|
||||
mli_track_click => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of clicks' },
|
||||
mli_num_opened => { type => 'INT', not_null => 1, default => 0, form_display => 'Number of Users opening this message' },
|
||||
mli_num_clicked => { type => 'INT', not_null => 1, default => 0, form_display => 'Number of clicks' },
|
||||
mli_scheduled => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Scheduled Mailing' },
|
||||
mli_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' }
|
||||
],
|
||||
pk => 'mli_id',
|
||||
ai => 'mli_id',
|
||||
fk => {
|
||||
Users => { mli_user_id_fk => 'usr_username' },
|
||||
CatMailing => { mli_cat_id_fk => 'cm_id' }
|
||||
},
|
||||
|
||||
index => {
|
||||
mi_ucdn => [qw/mli_user_id_fk mli_cat_id_fk mli_delete mli_done/],
|
||||
mi_c => ['mli_cat_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- EmailMailings Table -----------------
|
||||
create_table(\$output, 'EmailMailings', $action,
|
||||
cols => [
|
||||
eml_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
eml_mailing_id_fk => { type => 'INT', not_null => 1, form_display => 'Mailing ID' },
|
||||
eml_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Email Address', form_regex => $EMAIL_RE },
|
||||
eml_name => { type => 'CHAR', size => 50, form_display => 'Name' },
|
||||
eml_sent => { type => 'INT', not_null => 1, default => 0 },
|
||||
eml_bounced => { type => 'TINYINT', not_null => 1, default => 0 },
|
||||
eml_skipped => { type => 'TINYINT', not_null => 1, default => 0 },
|
||||
eml_opened => { type => 'INT', not_null => 1, default => 0 },
|
||||
eml_code => { type => 'CHAR', size => 100 => not_null => 1 },
|
||||
eml_lists => { type => 'TEXT', default => '' },
|
||||
],
|
||||
pk => 'eml_id',
|
||||
ai => 'eml_id',
|
||||
fk => { MailingIndex => { eml_mailing_id_fk => 'mli_id' } },
|
||||
index => {
|
||||
em_mb => [qw/eml_mailing_id_fk eml_bounced/],
|
||||
em_ms => [qw/eml_mailing_id_fk eml_sent/],
|
||||
em_mo => [qw/eml_mailing_id_fk eml_opened/],
|
||||
em_e => [qw/eml_email/],
|
||||
em_c => [qw/eml_code/],
|
||||
},
|
||||
unique => {
|
||||
em_me_q => [qw/eml_mailing_id_fk eml_email/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- ScheduledMailings Table -----------------
|
||||
create_table(\$output, 'ScheduledMailings', $action,
|
||||
cols => [
|
||||
scm_id => { type => 'INT', not_null => 1, form_display => 'Schedule ID'},
|
||||
scm_hour => { type => 'INT', default => 0, form_display => 'Hour' },
|
||||
scm_minute => { type => 'INT', default => 0, form_display => 'Minute' },
|
||||
scm_type => { type => 'TINYINT', default => 0, form_display => 'Schedule Type' },
|
||||
scm_option => { type => 'CHAR', size => 10, default => '', form_display => 'Option' },
|
||||
scm_text_url => { type => 'CHAR', size => 225, default => '', form_display => 'Text URL' },
|
||||
scm_html_url => { type => 'CHAR', size => 225, default => '', form_display => 'Html URL' },
|
||||
scm_inprocess => { type => 'TINYINT', default => 0, form_display => 'In Process' },
|
||||
scm_sent => { type => 'INT', default => 0, form_display => 'Sent Time' },
|
||||
scm_mailing_id_fk => { type => 'INT', default => 0, form_display => 'Mailing ID' },
|
||||
],
|
||||
ai => 'scm_id',
|
||||
pk => 'scm_id',
|
||||
unique => {
|
||||
sm_m_q => [qw/scm_mailing_id_fk/]
|
||||
},
|
||||
fk => { MailingIndex => { scm_mailing_id_fk => 'mli_id' } }
|
||||
);
|
||||
|
||||
#---------- MailingAttachments Table -----------------
|
||||
create_table(\$output, 'MailingAttachments', $action,
|
||||
cols => [
|
||||
mat_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
mat_mailing_id_fk => { type => 'INT', not_null => 1, form_display => 'Mailing ID' },
|
||||
mat_file_name => { type => 'CHAR', size => 255, form_display => 'File Name' },
|
||||
mat_file_size => { type => 'INT', form_display => 'File Size' },
|
||||
],
|
||||
pk => 'mat_id',
|
||||
ai => 'mat_id',
|
||||
fk => { MailingIndex => { mat_mailing_id_fk => 'mli_id' } },
|
||||
index => {
|
||||
mla_m => ['mat_mailing_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- StopLists Table -----------------
|
||||
create_table(\$output, 'StopLists', $action,
|
||||
cols => [
|
||||
stl_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
stl_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Email Address', form_regex => $EMAIL_RE },
|
||||
],
|
||||
pk => 'stl_id',
|
||||
ai => 'stl_id',
|
||||
unique => {
|
||||
s_e_q => ['stl_email']
|
||||
}
|
||||
);
|
||||
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub create_table {
|
||||
my ($output, $table, $action, @def) = @_;
|
||||
|
||||
$$output .= "Creating $table table ... ";
|
||||
my $c = $DB->creator($table);
|
||||
$c->clear_schema() if $action eq 'force';
|
||||
|
||||
@def % 2 and die "Odd number of table defs passed to create_table()";
|
||||
while (@def) {
|
||||
my ($meth, $arg) = splice @def, 0, 2;
|
||||
$c->$meth($arg);
|
||||
}
|
||||
|
||||
if ($c->create($action)) {
|
||||
$$output .= "okay\n";
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
$GT::SQL::errcode if 0; # silence "used only once" warnings
|
||||
$$output .= $GT::SQL::errcode eq 'TBLEXISTS' ? "failed (table already exists)\n" : "failed ($GT::SQL::error)\n";
|
||||
$c->set_defaults;
|
||||
$c->save_schema;
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub load_from_sql {
|
||||
# ---------------------------------------------------------------
|
||||
# Creates def files based on existing tables.
|
||||
#
|
||||
my ($output, $return);
|
||||
foreach my $table (@TABLES) {
|
||||
$output .= "$table .. ";
|
||||
my $c = $DB->creator($table);
|
||||
$return = $c->load_table($table);
|
||||
if ($return) {
|
||||
$output .= "ok\n";
|
||||
$c->save_schema();
|
||||
}
|
||||
else {
|
||||
$output .= "failed: $GT::SQL::error\n";
|
||||
}
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub load {
|
||||
# ---------------------------------------------------------------
|
||||
# Return a hash of current connection settings.
|
||||
#
|
||||
my %h = ();
|
||||
$h{prefix} = $DB->prefix();
|
||||
$h{database} = $DB->{connect}->{database};
|
||||
$h{login} = $DB->{connect}->{login};
|
||||
$h{password} = $DB->{connect}->{password};
|
||||
$h{host} = $DB->{connect}->{host};
|
||||
$h{host} .= ":" . $DB->{connect}->{port} if $DB->{connect}->{port};
|
||||
$h{driver} = $DB->{connect}->{driver};
|
||||
return \%h;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
144
site/glist/lib/GList/Template.pm
Normal file
144
site/glist/lib/GList/Template.pm
Normal file
@ -0,0 +1,144 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Template.pm,v 1.6 2004/03/10 01:04:53 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::Template;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
|
||||
use GList qw/:objects $DEBUG/;
|
||||
use GList::Config;
|
||||
use GT::Template;
|
||||
use vars qw/@ISA %VARS %MVARS/;
|
||||
|
||||
@ISA = qw/GT::Template/;
|
||||
|
||||
# Need to reset %VARS on each access of the page for mod_perl.
|
||||
# Takes no args.
|
||||
sub reset_env {
|
||||
%VARS = ();
|
||||
}
|
||||
|
||||
# Takes no args, returns all the mlist globals
|
||||
sub globals {
|
||||
my $g = {
|
||||
version => $GList::CFG->{version},
|
||||
image_url => $GList::CFG->{image_url},
|
||||
cgi_url => $GList::CFG->{cgi_url},
|
||||
root_path => $GList::CFG->{root_path},
|
||||
priv_path => $GList::CFG->{priv_path}
|
||||
};
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i and $ENV{HTTP_USER_AGENT} !~ /mac/i) {
|
||||
$g->{is_ie} = 1;
|
||||
$g->{ie_version} = $1;
|
||||
}
|
||||
|
||||
$g;
|
||||
}
|
||||
|
||||
# Takes 0 or 1 args - the template set. If not provided, it will try to use hidden 't' or else fall back to the Config default.
|
||||
sub template_globals {
|
||||
|
||||
my $globals = GT::Config->load("$GList::CFG->{priv_path}/templates/common/globals.txt", { create_ok => 1, inheritance => 1, local => 1, compile_subs => 'GList', header => <<HEADER });
|
||||
# This file is auto-generated and contains a perl hash of your
|
||||
# global variables for the template set.
|
||||
# Generated: [localtime]
|
||||
# vim:syn=perl:ts=4
|
||||
|
||||
HEADER
|
||||
|
||||
my $ret = {}; # Since we are converting the values in $globals to scalar references, the cache will become screwed up under mod_perl, so we have to copy them out into this.
|
||||
|
||||
for (keys %$globals) {
|
||||
my $val = $globals->{$_};
|
||||
if (ref $val) {
|
||||
$ret->{$_} = $val;
|
||||
}
|
||||
else {
|
||||
$val =~ s/<%image_url%>/$CFG->{image_url}/g;
|
||||
$ret->{$_} = \$val;
|
||||
}
|
||||
}
|
||||
|
||||
$ret;
|
||||
}
|
||||
|
||||
# This is useful to set variables inside a loop, then retrieve them outside the
|
||||
# loop. It stores them in %VARS.
|
||||
# It takes args as a hash ref.
|
||||
sub store_gvars {
|
||||
my %vars = @_;
|
||||
@MVARS{keys %vars} = values %vars;
|
||||
return;
|
||||
}
|
||||
|
||||
# Takes no args, but returns a reference to the hash containing the "kept"
|
||||
# variables that were set inside some sort of loop
|
||||
sub retrieve_gvars {
|
||||
\%MVARS
|
||||
}
|
||||
|
||||
# Takes all the args of GT::Template, but this changes them a bit before giving them to
|
||||
# GT::Template to add on the variables, globals, and template set globals.
|
||||
sub parse {
|
||||
my $globals = globals();
|
||||
my $set_globals = template_globals();
|
||||
|
||||
my $self = shift;
|
||||
|
||||
local %MVARS; # Localize this so that it will be empty for this parse
|
||||
my $page = $_[0];
|
||||
my ($vars, $opt) = @_[1, 2];
|
||||
my ($retvars, $retopt);
|
||||
if (ref $vars eq 'ARRAY') {
|
||||
# put it on the beginning so that anything else will overwrite it
|
||||
$retvars = [{ ($set_globals ? (%$set_globals) : ()), %$globals, %VARS }, @$vars]
|
||||
}
|
||||
elsif (ref $vars eq 'HASH' or UNIVERSAL::isa($vars, 'GT::Config')) {
|
||||
$retvars = {%$vars};
|
||||
# %VARS is first because it overrides mlist globals and template set globals.
|
||||
for (keys %VARS) {
|
||||
$retvars->{$_} = $VARS{$_} unless exists $retvars->{$_}
|
||||
}
|
||||
# Generally, installation globals should be be overridable by template set globals.
|
||||
for (keys %$globals) {
|
||||
$retvars->{$_} = $globals->{$_} unless exists $retvars->{$_}
|
||||
}
|
||||
# Template set globals are considered last and are only set if nothing else has set them.
|
||||
for (keys %$set_globals) {
|
||||
$retvars->{$_} = $set_globals->{$_} unless exists $retvars->{$_}
|
||||
}
|
||||
}
|
||||
elsif (ref $vars) {
|
||||
$retvars = [{ %$set_globals, %$globals, %VARS }, $vars]
|
||||
}
|
||||
else {
|
||||
$retvars = { %$set_globals, %$globals, %VARS }
|
||||
}
|
||||
|
||||
# Put the "escape" option on by default - it specifically has to be
|
||||
# specified as 0 to disable it.
|
||||
if ($opt) {
|
||||
$retopt = {%$opt};
|
||||
$retopt->{escape} = 1 unless exists $retopt->{escape};
|
||||
$retopt->{compress} = $CFG->{compress} unless exists $retopt->{compress};
|
||||
}
|
||||
else {
|
||||
$retopt = { escape => 1, compress => $CFG->{compress} };
|
||||
}
|
||||
$retopt->{debug_level} = $CFG->{debug_level} if $CFG->{debug_level};
|
||||
$self->SUPER::parse($_[0], $retvars, $retopt, @_[3 .. $#_]);
|
||||
}
|
||||
|
||||
1;
|
||||
532
site/glist/lib/GList/Tools.pm
Normal file
532
site/glist/lib/GList/Tools.pm
Normal file
@ -0,0 +1,532 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Tools.pm,v 1.37 2004/10/06 17:58:17 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::Tools;
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects $LANGUAGE $GLOBALS/;
|
||||
|
||||
use constants KB => 1024, MB => 1024 * 1024;
|
||||
|
||||
sub generate_used_bar {
|
||||
#-------------------------------------------------------------------
|
||||
#
|
||||
my ($type, $max_width) = @_;
|
||||
|
||||
my ($percent, $img_width, $msg) = (0, 0, '');
|
||||
if ($type eq 'email30') {
|
||||
require GT::Date;
|
||||
require GT::SQL::Condition;
|
||||
my $last30 = GT::Date::date_sub(GT::Date::date_get(), 30);
|
||||
my $unix_time = GList::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}) {
|
||||
$percent = 100;
|
||||
$img_width = $max_width;
|
||||
}
|
||||
else {
|
||||
$percent = int(100 * $num_sent / $USER->{usr_limit_email30});
|
||||
$img_width = int($num_sent * $max_width / $USER->{usr_limit_email30});
|
||||
}
|
||||
$msg = GList::language('SYS_USEDBAR_EMAIL30', $percent, $USER->{usr_limit_email30});
|
||||
}
|
||||
elsif ($type eq 'sublist') {
|
||||
my $num_lists = $DB->table('Lists')->count({ lst_user_id_fk => $USER->{usr_username} });
|
||||
my $num_subs = $DB->table('Subscribers')->count({ sub_user_id_fk => $USER->{usr_username} });
|
||||
my $sub_limit = ($num_lists) ? $num_lists * $USER->{usr_limit_sublist} : $USER->{usr_limit_sublist};
|
||||
if ($num_subs >= $sub_limit) {
|
||||
$percent = 100;
|
||||
$img_width = $max_width;
|
||||
}
|
||||
else {
|
||||
$percent = int(100 * $num_subs / $sub_limit);
|
||||
$img_width = int($num_subs * $max_width / $sub_limit);
|
||||
}
|
||||
$msg = GList::language('SYS_USEDBAR_SUBLIST', $percent, $sub_limit);
|
||||
}
|
||||
return { used_message => $msg, used_percent => $percent, used_image_width => $img_width };
|
||||
}
|
||||
|
||||
sub generate_list {
|
||||
# ------------------------------------------------------------------
|
||||
# Generates a list of lists
|
||||
#
|
||||
my $object = shift;
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $lists = $DB->table('Lists');
|
||||
$lists->select_options('ORDER BY lst_Title');
|
||||
|
||||
my $sth = $lists->select({ lst_user_id_fk => $tags->{usr_username} }) or die $GT::SQL::error;
|
||||
my $html = "";
|
||||
my $current = $tags->{$object};
|
||||
while ( my $rs = $sth->fetchrow_hashref ) {
|
||||
if (ref $current eq 'ARRAY') {
|
||||
my $id = 0;
|
||||
foreach (@$current) {
|
||||
if ($_ == $rs->{lst_id}) {
|
||||
$id = $_;last;
|
||||
}
|
||||
}
|
||||
$html .= ( $id == $rs->{lst_id} ) ? "<option value='$rs->{lst_id}' selected>$rs->{lst_title}</option>"
|
||||
: "<option value='$rs->{lst_id}'>$rs->{lst_title}</option>";
|
||||
}
|
||||
else {
|
||||
$html .= ( $current == $rs->{lst_id} ) ? "<option value='$rs->{lst_id}' selected>$rs->{lst_title}</option>"
|
||||
: "<option value='$rs->{lst_id}'>$rs->{lst_title}</option>";
|
||||
}
|
||||
}
|
||||
return $html;
|
||||
}
|
||||
|
||||
sub default_email_editor {
|
||||
#------------------------------------------------------------------
|
||||
# Load the default email templates editor
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
my $selected_dir = $cgi->{tpl_dir} || $CFG->{template_set} || 'gossamer';
|
||||
|
||||
my $demo;
|
||||
#------------demo code-----------
|
||||
|
||||
# Build the select lists.
|
||||
my $d_select_list = _template_dir_select();
|
||||
my ($f_select_list, $selected_file) = _default_select("$CFG->{priv_path}/templates/$selected_dir", $cgi->{tpl_file});
|
||||
|
||||
return { select_list => $f_select_list, tpl_dir => "$CFG->{priv_path}/templates/", selected_dir => $selected_dir, dir_select => $d_select_list, demo => $demo, tpl_file => $selected_file, bload => ($selected_file) ? 1 : 0 };
|
||||
}
|
||||
|
||||
sub email_editor {
|
||||
#------------------------------------------------------------------
|
||||
# Load the email template editor
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
my $tpl = {};
|
||||
my $db = $DB->table('EmailTemplates');
|
||||
my $cols = $db->cols;
|
||||
my ($msg, $error, $demo);
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
# Save the email template
|
||||
my $save_as = $cgi->{save_as};
|
||||
if ( $cgi->{bsave} and $save_as ) {
|
||||
if ( $demo ) {
|
||||
$msg = '<font color="red">Edit email template has been disabled in the demo!</font>';
|
||||
}
|
||||
else {
|
||||
my @required = ('tpl_to', 'tpl_from', 'tpl_subject', 'tpl_body');
|
||||
my $hsh = {};
|
||||
foreach ( @required ) {
|
||||
$hsh->{$_} = $cgi->{$_} if ( defined $cgi->{$_} );
|
||||
}
|
||||
$hsh->{tpl_user_id_fk} = $tags->{usr_username};
|
||||
$hsh->{tpl_name} = $save_as;
|
||||
if ( $cgi->{tpl_extra} ) {
|
||||
for ( split /\s*\n\s*/, $cgi->{tpl_extra} ) { # This will weed out any blank lines
|
||||
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
||||
$hsh->{tpl_extra} .= "$key: $value\n" if $key and $value;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$hsh->{tpl_extra} = '';
|
||||
}
|
||||
|
||||
foreach ( @required ) {
|
||||
if ( !$hsh->{$_} ) {
|
||||
$msg = GList::language('TPL_INVALID');
|
||||
$error = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ( !$msg ) {
|
||||
if ( $save_as eq $cgi->{tpl_name} ) { # Update an exist template
|
||||
$db->update($hsh, { tpl_user_id_fk => $tags->{usr_username}, tpl_name => $save_as });
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_UPDATED', $save_as);
|
||||
}
|
||||
else { # Add a new template
|
||||
$db->insert($hsh);
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_ADDED', $save_as);
|
||||
$cgi->{tpl_name} = $save_as if ( !$GT::SQL::error );
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $cgi->{txtdelete} ) { # Delete an existing template
|
||||
if ( $demo ) {
|
||||
$msg = '<font color="red">Edit email template has been disabled in the demo !</font>';
|
||||
}
|
||||
else {
|
||||
require GT::SQL::Condition;
|
||||
my $cond = GT::SQL::Condition->new('lst_user_id_fk', '=', $tags->{usr_username});
|
||||
$cond->add(GT::SQL::Condition->new('lst_opt_template', '=', $cgi->{tpl_name}, 'lst_subs_template', '=', $cgi->{tpl_name}, 'lst_unsubs_template', '=', $cgi->{tpl_name}, 'OR'));
|
||||
|
||||
my $sth = $DB->table('Lists')->select($cond);
|
||||
if ( $sth->rows ) {
|
||||
$msg = GList::language('TPL_DELETE_ERROR', $cgi->{tpl_name});
|
||||
}
|
||||
else {
|
||||
$db->delete({ tpl_user_id_fk => $tags->{usr_username}, tpl_name => $cgi->{tpl_name} });
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_DELETED', $cgi->{tpl_name});
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $cgi->{bdefault} ) { # Load default templates
|
||||
GList::set_default_template('validation.eml', $tags->{usr_username});
|
||||
GList::set_default_template('subscribe.eml', $tags->{usr_username});
|
||||
GList::set_default_template('unsubscribe.eml', $tags->{usr_username});
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_LOADED');
|
||||
}
|
||||
|
||||
# Build the select lists.
|
||||
my $f_current_list = _current_select('tpl_name', $cgi->{tpl_name});
|
||||
if ( $cgi->{tpl_name} and !$GT::SQL::error and !$error ) {
|
||||
$tpl = $db->get({ tpl_user_id_fk => $tags->{usr_username}, tpl_name => $cgi->{tpl_name} });
|
||||
if ( !$tpl ) {
|
||||
foreach (keys %$cols) { $tpl->{$_} = ''; }
|
||||
}
|
||||
}
|
||||
|
||||
return { current_list => $f_current_list, msg => $msg, %$tpl };
|
||||
}
|
||||
|
||||
sub template_editor {
|
||||
# ------------------------------------------------------------------
|
||||
# Loads the template editor.
|
||||
#
|
||||
_editor_obj()->process;
|
||||
}
|
||||
|
||||
sub language_editor {
|
||||
# ------------------------------------------------------------------
|
||||
# Loads the language file editor.
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my ($font, $message, $table);
|
||||
my $cgi = $IN->get_hash;
|
||||
my $selected_dir = $cgi->{tpl_dir} || $CFG->{template_set} || 'gossamer';
|
||||
|
||||
$font = 'face="Tahoma,Arial,Helvetica" size="2"';
|
||||
|
||||
my $demo;
|
||||
#------------demo code-----------
|
||||
|
||||
GList::load_language($selected_dir);
|
||||
|
||||
if ($cgi->{save}) {
|
||||
if ($demo) {
|
||||
$message = '<font color="red">The language editor has been disabled in the demo!</font>';
|
||||
}
|
||||
else {
|
||||
my $need_save;
|
||||
foreach my $code (keys %$cgi) {
|
||||
if ($code =~ /^del-(.*)$/) {
|
||||
delete $LANGUAGE->{$1};
|
||||
++$need_save;
|
||||
}
|
||||
elsif ($code =~ /^save-(.*)/) {
|
||||
my $key = $1;
|
||||
next if $cgi->{"del-$key"};
|
||||
my $var = $cgi->{$code};
|
||||
$var =~ s/\r\n/\n/g; # Remove windows linefeeds.
|
||||
next if exists $LANGUAGE->{$key} and $LANGUAGE->{$key} eq $var;
|
||||
$LANGUAGE->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
}
|
||||
|
||||
if (my $key = $cgi->{new} and my $var = $cgi->{'new-val'}) {
|
||||
$var =~ s/\r\n/\n/g;
|
||||
if ($key =~ /^([^_]*)_/) {
|
||||
$LANGUAGE->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
else {
|
||||
$message = GList::language('TPL_LANG_INVALID');
|
||||
}
|
||||
}
|
||||
elsif ($cgi->{'new-val'}) {
|
||||
$message = GList::language('TPL_LANG_ERROR');
|
||||
}
|
||||
|
||||
if ($need_save) {
|
||||
$LANGUAGE->save();
|
||||
$LANGUAGE = undef; # Force a reload to catch inherited values
|
||||
$message = GList::language('TPL_LANG_SAVED');
|
||||
$tags->{'new-val'} = '';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $prefix = $cgi->{'prefix'};
|
||||
my %prefix_list;
|
||||
foreach my $code (sort keys %$LANGUAGE) {
|
||||
if ($code =~ /^([^_]*)_/) {
|
||||
$prefix_list{$1}++;
|
||||
}
|
||||
next if $prefix and $code !~ /^$prefix\_/;
|
||||
my $lang = $IN->html_escape($LANGUAGE->{$code});
|
||||
$table .= <<HTML;
|
||||
<tr>
|
||||
<td valign=top><font $font>$code</font></td>
|
||||
<td>
|
||||
<textarea rows="5" cols="50" name="save-$code" class="object">$lang</textarea>
|
||||
</td>
|
||||
<td><input type=checkbox name="del-$code" value="1" /></td>
|
||||
</tr>
|
||||
HTML
|
||||
}
|
||||
my $prefix_output = join " | ",
|
||||
map qq'<a href="$CFG->{cgi_url}/glist.cgi?do=admin_page;pg=admin_template_language.html;prefix=$_;tpl_dir=$selected_dir"><nobr>$_ ($prefix_list{$_})</nobr></a>',
|
||||
sort keys %prefix_list;
|
||||
|
||||
my $d_select_list = _template_dir_select();
|
||||
|
||||
return {
|
||||
language_table => $table,
|
||||
prefix => $prefix,
|
||||
dir_select => $d_select_list,
|
||||
message => $message,
|
||||
prefix_list => $prefix_output
|
||||
};
|
||||
}
|
||||
|
||||
sub global_editor {
|
||||
# ------------------------------------------------------------------
|
||||
# Loads the global template vars.
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
my ($dir, $font, $file, $message, $table);
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
my $selected_dir = $cgi->{tpl_dir} || $CFG->{template_set} || 'gossamer';
|
||||
$dir = $CFG->{priv_path} . "/templates/common";
|
||||
|
||||
GList::load_globals(1);
|
||||
|
||||
my $demo;
|
||||
#------------demo code-----------
|
||||
|
||||
if ($cgi->{save}) {
|
||||
if ($demo) {
|
||||
$message = '<font color="red">The global editor has been disabled in the demo!</font>';
|
||||
}
|
||||
else {
|
||||
my $need_save;
|
||||
foreach my $code (keys %$cgi) {
|
||||
if ($code =~ /^del-(.*)$/) {
|
||||
delete $GLOBALS->{$1};
|
||||
++$need_save;
|
||||
}
|
||||
elsif ($code =~ /^save-(.*)/) {
|
||||
my $key = $1;
|
||||
next if $cgi->{"del-$key"};
|
||||
my $var = $cgi->{$code};
|
||||
$var =~ s/\r\n/\n/g; # Remove windows linefeeds.
|
||||
next if exists $GLOBALS->{$key} and $GLOBALS->{$key} eq $var;
|
||||
$GLOBALS->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
}
|
||||
|
||||
if (my $key = $cgi->{new} and my $var = $cgi->{'new-val'}) {
|
||||
$var =~ s/\r\n/\n/g;
|
||||
$GLOBALS->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
elsif ($cgi->{'new-val'}) {
|
||||
$message = GList::language('TPL_GLOBAL_ERROR');
|
||||
}
|
||||
|
||||
if ($need_save) {
|
||||
$GLOBALS->save();
|
||||
$GLOBALS = undef; # Force a reload, to catch inherited/local values
|
||||
GList::load_globals(1);
|
||||
$message = GList::language('TPL_GLOBAL_SAVED');
|
||||
$tags->{'new-val'} = '';
|
||||
}
|
||||
}
|
||||
}
|
||||
for my $code (sort keys %$GLOBALS) {
|
||||
my $val = $IN->html_escape($GLOBALS->{$code});
|
||||
$table .= <<HTML;
|
||||
<tr>
|
||||
<td valign="top" class="body">$code</td>
|
||||
<td>
|
||||
<textarea rows="5" cols="50" name="save-$code" wrap="off" class="object">$val</textarea>
|
||||
</td>
|
||||
<td><input type="checkbox" name="del-$code" value="1"></td>
|
||||
</tr>
|
||||
HTML
|
||||
}
|
||||
return { global_table => $table, message => $message };
|
||||
}
|
||||
|
||||
sub convert_date {
|
||||
#----------------------------------------------------------------------
|
||||
my $time = shift or return GList::language('ADMNEVER_LOGIN');
|
||||
my $format = "%mm%-%dd%-%yyyy% %hh%:%MM%:%ss%";
|
||||
|
||||
require GT::Date;
|
||||
return GT::Date::date_get($time, $format);
|
||||
}
|
||||
|
||||
sub friendly_size {
|
||||
my $size = shift;
|
||||
return $size <= 100
|
||||
? "$size " . GList::language('FILESIZE_BYTES')
|
||||
: $size < 10 * KB
|
||||
? sprintf("%.2f ", $size / KB) . GList::language('FILESIZE_KILOBYTES')
|
||||
: $size < 100 * KB
|
||||
? sprintf("%.1f ", $size / KB) . GList::language('FILESIZE_KILOBYTES')
|
||||
: $size < MB
|
||||
? sprintf("%.0f ", $size / KB) . GList::language('FILESIZE_KILOBYTES')
|
||||
: $size < 10 * MB
|
||||
? sprintf("%.2f ", $size / MB) . GList::language('FILESIZE_MEGABYTES')
|
||||
: $size < 100 * MB
|
||||
? sprintf("%.1f ", $size / MB) . GList::language('FILESIZE_MEGABYTES')
|
||||
: sprintf("%.0f ", $size / MB) . GList::language('FILESIZE_MEGABYTES');
|
||||
}
|
||||
|
||||
sub list_title {
|
||||
my $list_id = shift;
|
||||
return if (!$list_id);
|
||||
|
||||
my $info = $DB->table('Lists')->get($list_id);
|
||||
return $info->{lst_title};
|
||||
}
|
||||
|
||||
sub _editor_obj {
|
||||
my ($name, $skip) = @_;
|
||||
$skip ||= [qw/CVS safe help/];
|
||||
require GT::Template::Editor;
|
||||
my $demo = 0;
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
GT::Template::Editor->new(
|
||||
root => "$CFG->{priv_path}/templates",
|
||||
backup => $CFG->{template_backups},
|
||||
cgi => $IN,
|
||||
demo => $demo,
|
||||
class => "object",
|
||||
default_dir => $CFG->{template_set} || 'gossamer',
|
||||
skip_dir => $skip,
|
||||
skip_file => [qw/*.eml/],
|
||||
$name ? (select_dir => $name) : ()
|
||||
);
|
||||
}
|
||||
|
||||
sub _template_dir_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of template directories.
|
||||
#
|
||||
my $name = shift;
|
||||
_editor_obj($name, [qw/CVS help safe common/])->template_dir_select;
|
||||
}
|
||||
|
||||
sub _current_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of user email templates
|
||||
#
|
||||
my ($name, $selected_file) = @_;
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $sth = $DB->table('EmailTemplates')->select({ tpl_user_id_fk => $tags->{usr_username} }, ['tpl_name']);
|
||||
return if ( !$sth->rows );
|
||||
$selected_file ||= $tags->{$name};
|
||||
|
||||
my $f_select_list = "<select name='$name' class=object><option value=''>".GList::language('TPL_SELECT_TITLE')."</option>";
|
||||
while ( my $name = $sth->fetchrow_array ) {
|
||||
( $selected_file eq $name ) ? ($f_select_list .= "<option selected>$name") : ($f_select_list .= "<option>$name");
|
||||
}
|
||||
|
||||
return "$f_select_list</select>";
|
||||
}
|
||||
|
||||
sub _default_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of email templates in a given dir.
|
||||
#
|
||||
my ( $dir, $selected_file ) = @_;
|
||||
|
||||
my ($file, @files);
|
||||
opendir (TPL, $dir) or die GList::language('DIR_OPEN_ERR', $dir, $!);
|
||||
|
||||
while (defined($file = readdir TPL)) {
|
||||
my ($ext) = $file =~ /\.([^.]+)$/;
|
||||
next unless $ext and $ext eq 'eml';
|
||||
push @files, $file;
|
||||
}
|
||||
closedir TPL;
|
||||
|
||||
my $f_select_list = "<select name='tpl_file' class=object><option value=''>".GList::language('TPL_SELECT_TITLE')."</option>";
|
||||
my $count = 0;
|
||||
foreach (sort @files) {
|
||||
$selected_file = $_ if (!$selected_file and !$count);
|
||||
($selected_file eq $_) ? ($f_select_list .= "<option selected>$_</option>") : ($f_select_list .= "<option>$_</option>");
|
||||
}
|
||||
$f_select_list .= "</select>";
|
||||
|
||||
return ($f_select_list, $selected_file);
|
||||
}
|
||||
|
||||
sub schedule_status {
|
||||
my $tags = GT::Template->tags;
|
||||
my ($scm_id, $scm_sent, $scm_type) = ($tags->{scm_id}, $tags->{scm_sent}, $tags->{scm_type});
|
||||
|
||||
my $schedule = $DB->table('ScheduledMailings')->get({ scm_id => $scm_id });
|
||||
return unless $schedule;
|
||||
return unless $scm_sent;
|
||||
|
||||
require GT::Date;
|
||||
if ($scm_type == 2) {
|
||||
return 1 if GT::Date::date_get(time, "%yyyy%-%mm%-%dd%") eq GT::Date::date_get($scm_sent, "%yyyy%-%mm%-%dd%");
|
||||
}
|
||||
elsif ($scm_type == 3) {
|
||||
my $today = GT::Date::date_get(time, "%yyyy%-%mm%-%dd%");
|
||||
my $next_7days = GT::Date::date_add(GT::Date::date_get($scm_sent, "%yyyy%-%mm%-%dd%"), 7);
|
||||
return GT::Date::date_is_greater($next_7days, $today);
|
||||
}
|
||||
elsif ($scm_type == 4) {
|
||||
return 1 if GT::Date::date_get(time, "%mm%") eq GT::Date::date_get($scm_sent, "%mm%");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub schedule_info {
|
||||
my $mli_id = shift;
|
||||
|
||||
return unless $mli_id;
|
||||
my $info = $DB->table('ScheduledMailings')->get({ scm_mailing_id_fk => $mli_id });
|
||||
if ($info->{scm_type} == 1) {
|
||||
require GT::Date;
|
||||
my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
$info->{scm_option} = GT::Date::date_get($info->{scm_option}, $format);
|
||||
}
|
||||
return $info;
|
||||
}
|
||||
1;
|
||||
879
site/glist/lib/GList/User.pm
Normal file
879
site/glist/lib/GList/User.pm
Normal file
@ -0,0 +1,879 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: User.pm,v 1.49 2004/10/14 22:57:54 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::User;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects :user_type $DEBUG/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
sub process {
|
||||
#-------------------------------------------------------------------
|
||||
# Determine what to do
|
||||
#
|
||||
my $do = shift;
|
||||
|
||||
my $action = _determine_action($do) or die "Error: Invalid Action! ($do)";
|
||||
|
||||
my ($tpl, $results) = GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action);
|
||||
$tpl ||= 'user_login.html';
|
||||
GList::display($tpl, $results);
|
||||
}
|
||||
|
||||
$COMPILE{user_click} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_click {
|
||||
#--------------------------------------------------------------------
|
||||
# Track number of clicks
|
||||
#
|
||||
my $id = $IN->param('mailing');
|
||||
my $url = $IN->param('url') || "$CFG->{cgi_url}/glist.cgi";
|
||||
my $db = $DB->table('MailingIndex');
|
||||
if ($db->count({ mli_id => $id })) {
|
||||
$db->update({ mli_num_clicked => \'mli_num_clicked + 1' }, { mli_id => $id });
|
||||
}
|
||||
print $IN->header( -url => $url );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_open} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_open {
|
||||
#--------------------------------------------------------------------
|
||||
# Track number of users who open message
|
||||
#
|
||||
my $code = $IN->param('eml_code');
|
||||
my $mailing = $IN->param('mailing');
|
||||
my $db = $DB->table('EmailMailings');
|
||||
if ($code and $mailing and $db->count({ eml_mailing_id_fk => $mailing, eml_code => $code, eml_opened => 0 })) {
|
||||
$db->update({ eml_opened => time }, { eml_mailing_id_fk => $mailing, eml_code => $code });
|
||||
$DB->table('MailingIndex')->update({ mli_num_opened => \'mli_num_opened + 1' }, { mli_id => $mailing });
|
||||
}
|
||||
if (open DATA, "$CFG->{image_path}/pics/1pixel.gif") {
|
||||
print $IN->header({
|
||||
'-type' => 'image/gif',
|
||||
'-Content-Length' => -s "$CFG->{image_path}/pics/1pixel.gif",
|
||||
});
|
||||
binmode STDOUT;
|
||||
binmode DATA;
|
||||
my $buffer;
|
||||
print $buffer while (read(DATA, $buffer, 50000));
|
||||
close DATA;
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_signup} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_signup {
|
||||
# -------------------------------------------------------------------
|
||||
# User Sign-up
|
||||
#
|
||||
return ('user_login.html', { msg => GList::language('USR_SIGNUP_DISABLE') }) if (!$CFG->{signup_enable});
|
||||
|
||||
return ('user_signup.html') if ($IN->param('form'));
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
my $error = _signup_check($cgi);
|
||||
return ('user_signup.html', { msg => $error }) if ($error);
|
||||
|
||||
$cgi->{usr_password} = GList::encrypt($cgi->{usr_password});
|
||||
$cgi->{usr_date_format}||= "%yyyy%-%mm%-%dd%";
|
||||
$cgi->{usr_bounce_email} = $cgi->{usr_email};
|
||||
$cgi->{usr_reply_email} = $cgi->{usr_email};
|
||||
$cgi->{usr_limit_list} = $CFG->{signup_limit_list} || 10;
|
||||
$cgi->{usr_limit_sublist}= $CFG->{signup_limit_sublist} || 10;
|
||||
$cgi->{usr_limit_email30}= $CFG->{signup_limit_email30} || 100;
|
||||
$cgi->{usr_type} = (!$CFG->{signup_email_validate} and !$CFG->{signup_admin_validate}) ? LIMITED_USER : UNVALIDATED_USER;
|
||||
my $info = $cgi;
|
||||
|
||||
# if it requires email validate
|
||||
if ($CFG->{signup_email_validate}) {
|
||||
my $val_code = join '', ('a'..'z', 'A'..'Z', 0..9)[map rand(62), 1 .. 30];
|
||||
$cgi->{usr_validate_code} = "GT$val_code";
|
||||
$info->{validate_code} = $val_code;
|
||||
}
|
||||
|
||||
GList::add('Users', 'usr', $cgi);
|
||||
return ('user_signup.html', { msg => "<font color=red><b>$GList::error</b></font>" }) if ($GList::error);
|
||||
|
||||
# Send a validate email
|
||||
my $msg = GList::language('USR_SIGNUP_SUCCESSFUL');
|
||||
if ($CFG->{signup_email_validate}) {
|
||||
foreach (keys %{$CFG->{admin}}) {
|
||||
next if (!$_);
|
||||
$info->{admin_email} = $CFG->{admin}->{$_}->[1]; last;
|
||||
}
|
||||
|
||||
my ($head, $body) = _parse_file('account_validation.eml', $info);
|
||||
GList::send($head, { text => $body });
|
||||
$msg = GList::language('USR_SIGNUP_EMAIL_SUCCESSFUL');
|
||||
}
|
||||
return ('user_login.html', { msg => $msg });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_account_validate} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_account_validate {
|
||||
#----------------------------------------------------------
|
||||
# User validate
|
||||
#
|
||||
my $id = $IN->param('id');
|
||||
my $db = $DB->table('Users');
|
||||
my $found= $db->count({ usr_validate_code => $id });
|
||||
return ('user_login.html', { msg => GList::language('USR_VALIDATE_FAILED') }) unless ($found);
|
||||
|
||||
# if it requires admin validate
|
||||
my %hash = (usr_validate_code => '', usr_type => LIMITED_USER);
|
||||
if ($CFG->{signup_admin_validate}) {
|
||||
$hash{usr_type} = UNVALIDATED_USER;
|
||||
}
|
||||
$db->update(\%hash, { usr_validate_code => $id });
|
||||
return ('user_login.html', { msg => GList::language('USR_VALIDATE_SUCCESSFUL') });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_login} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_login {
|
||||
# --------------------------------------------------------
|
||||
# Logs a user in, and creates a session ID.
|
||||
#
|
||||
|
||||
if (!defined $IN->param('username') or !defined $IN->param('password')) {
|
||||
return ('user_login.html', { msg => GList::language('LOG_IN', GList::_load_global('site_title')) });
|
||||
}
|
||||
|
||||
my $username = $IN->param('username') || shift;
|
||||
my $password = $IN->param('password') || shift;
|
||||
|
||||
# Make sure we have both a username and password.
|
||||
return ('user_login.html', { msg => GList::language('LOG_ERROR') }) if (!$username or !$password);
|
||||
|
||||
unless (GList::test_connection()) { # Database connection is failed
|
||||
if (GList::Authenticate::auth('admin_valid_user', { username => $username, password => $password })) {
|
||||
my $session = GList::Authenticate::auth('admin_create_session', { username => $username });
|
||||
if ($session) {
|
||||
$USER->{admin_user} = $username;
|
||||
$USER->{admin_pass} = $password;
|
||||
$USER->{session_id} = $session->{session_id};
|
||||
$USER->{use_cookie} = $session->{use_cookie};
|
||||
require GList::Admin;
|
||||
return GList::Admin::admin_initial_sql();
|
||||
}
|
||||
}
|
||||
return ('user_login.html', { msg => GList::language('LOG_ERROR') });
|
||||
}
|
||||
|
||||
# Check that the user exists, and that the password is valid.
|
||||
my $user = GList::init_user($username, $password);
|
||||
return ('user_login.html', { msg => GList::language('LOG_DEACTIVATE') }) if ($user and $user == 1);
|
||||
return ('user_login.html', { msg => GList::language('LOG_NOT_EMAIL_VALIDATED') }) if ($user and $user == 2);
|
||||
return ('user_login.html', { msg => GList::language('LOG_NOT_ADMIN_VALIDATED') }) if ($user and $user == 3);
|
||||
return ('user_login.html', { msg => GList::language('LOG_ERROR') }) if (ref $user ne 'HASH');
|
||||
|
||||
# Store the session in either a cookie or url based.
|
||||
my $results = GList::Authenticate::auth('create_session', { username => $user->{usr_username} });
|
||||
|
||||
return ('user_login.html', { msg => "<font color=red><b>$results->{error}</b></font>" }) if ($results->{error});
|
||||
$USER->{session_id} = $results->{session_id};
|
||||
$USER->{use_cookie} = $results->{use_cookie};
|
||||
|
||||
_cleanup_files();
|
||||
|
||||
if ($USER->{usr_updated}) {
|
||||
$MN_SELECTED = 1;
|
||||
require GList::Message;
|
||||
return GList::Message::msg_home(GList::language('LOG_WELCOME', "$USER->{pro_first_name} $USER->{pro_last_name}"));
|
||||
}
|
||||
else {
|
||||
$MN_SELECTED = 5;
|
||||
require GList::Profile;
|
||||
return GList::Profile::pro_profile(GList::language('LOG_UPDATE_REMIND'));
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_logout} = <<'END_OF_SUB';
|
||||
sub user_logout {
|
||||
#-----------------------------------------------------------
|
||||
#
|
||||
require GList::Authenticate;
|
||||
GList::Authenticate::auth('delete_session');
|
||||
return ('user_login.html', { msg => GList::language('LOG_LOGGED_OFF', GList::_load_global('site_title')) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_remind} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_remind {
|
||||
#---------------------------------------------------------
|
||||
# Send password to a user
|
||||
#
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
return ('user_remind_form.html') if (!defined $IN->param('email'));
|
||||
|
||||
my $email = $IN->param('email');
|
||||
return ('user_remind_form.html', { msg => GList::language('LOG_REM_ERROR') }) unless ($email);
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $user = $db->get({ usr_email => $email });
|
||||
return ('user_remind_form.html', { msg => GList::language('LOG_REM_NOT_FOUND') }) if (!$user);
|
||||
|
||||
# Get Administrator info
|
||||
my $info;
|
||||
my $admin = $db->get({ usr_type => LIMITED_USER });
|
||||
if ($admin) {
|
||||
$info->{admin_email} = $admin->{usr_email};
|
||||
}
|
||||
|
||||
my @letters = (0 .. 9, 'a' .. 'z', 'A' .. 'Z');
|
||||
my $temp = '';
|
||||
for (1 .. 6) { $temp .= $letters[rand @letters]; }
|
||||
my $temp_enc = GList::encrypt($temp);
|
||||
$db->update({ usr_password => $temp_enc }, { usr_username => $user->{usr_username} });
|
||||
|
||||
$info->{usr_username} = $user->{usr_username};
|
||||
$info->{usr_email} = $user->{usr_email};
|
||||
$info->{usr_password} = $temp;
|
||||
$info->{usr_name} = "$user->{pro_first_name} $user->{pro_last_name}";
|
||||
$info->{usr_name} ||= $user->{usr_username};
|
||||
|
||||
my ($head, $body) = _parse_file('remindme.eml', $info);
|
||||
GList::send($head, { text => $body });
|
||||
|
||||
return ('user_login.html', { msg => GList::language('LOG_REM_SUCCESS', $email) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_validate} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_validate {
|
||||
#-----------------------------------------------------------
|
||||
# Validate a subscriber
|
||||
#
|
||||
|
||||
my $admin = $db->get({ usr_type => LIMITED_USER });
|
||||
if ($admin) {
|
||||
$info->{admin_email} = $admin->{usr_email};
|
||||
}
|
||||
|
||||
my @letters = (0 .. 9, 'a' .. 'z', 'A' .. 'Z');
|
||||
my $temp = '';
|
||||
for (1 .. 6) { $temp .= $letters[rand @letters]; }
|
||||
my $temp_enc = GList::encrypt($temp);
|
||||
$db->update({ usr_password => $temp_enc }, { usr_username => $user->{usr_username} });
|
||||
|
||||
$info->{usr_username} = $user->{usr_username};
|
||||
$info->{usr_email} = $user->{usr_email};
|
||||
$info->{usr_password} = $temp;
|
||||
$info->{usr_name} = "$user->{pro_first_name} $user->{pro_last_name}";
|
||||
$info->{usr_name} ||= $user->{usr_username};
|
||||
|
||||
my ($head, $body) = _parse_file('remindme.eml', $info);
|
||||
GList::send($head, { text => $body });
|
||||
|
||||
return ('user_login.html', { msg => GList::language('LOG_REM_SUCCESS', $email) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_validate} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_validate {
|
||||
#-----------------------------------------------------------
|
||||
# Validate a subscriber
|
||||
#
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
my $id = $IN->param('id');
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $info = $db->get({ sub_val_code => $id });
|
||||
|
||||
return ('error_form.html', { msg => GList::language('LOG_VAL_ERROR') }) if (!$info);
|
||||
return ('error_form.html', { msg => GList::language('LOG_VAL_ERROR2') }) if ($info->{sub_validated});
|
||||
|
||||
$db->update({ sub_validated => '1' }, { sub_val_code => $id });
|
||||
|
||||
my $lst_info = $DB->table('Lists')->get($info->{sub_list_id_fk});
|
||||
return ('user_success_form.html', { msg => GList::language('LOG_VALIDATED') }) if (!$lst_info->{lst_url_validate_success});
|
||||
|
||||
print $IN->header( -url => $lst_info->{lst_url_validate_success} );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_subscribe} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_subscribe {
|
||||
#-----------------------------------------------------------
|
||||
# Subscribe a email address
|
||||
#
|
||||
# get subscribe success URLs
|
||||
my $url_success = "$CFG->{static_url}/page/subscribe_success.html";
|
||||
my $url_failure = "$CFG->{static_url}/page/subscribe_failure.html";
|
||||
# get the hash for this CGI instance
|
||||
my $cgi = $IN->get_hash();
|
||||
my $demo = 0;
|
||||
# errors if we don't have an accurate list ID
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR') }) unless ($cgi->{lid});
|
||||
|
||||
#------------demo code-----------
|
||||
# $demo = 1;
|
||||
|
||||
# Get the relevant table lsits (Subscribers). StopLists is the unknown one--doesn't look like it's used anymore
|
||||
my $db_sub = $DB->table('Subscribers');
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
my $email;
|
||||
if ($cgi->{eml_code}) {
|
||||
my $eml = $DB->table('EmailMailings')->get({ eml_code => $cgi->{eml_code} });
|
||||
$email = lc $eml->{eml_email};
|
||||
}
|
||||
else {
|
||||
$email = lc $cgi->{email};
|
||||
}
|
||||
|
||||
# if there's an array of IDs, loop over them
|
||||
if (ref $cgi->{lid} eq 'ARRAY') {
|
||||
foreach my $id (@{$cgi->{lid}}) {
|
||||
my $info = $DB->table('Lists')->get($id);
|
||||
next unless ($info);
|
||||
|
||||
my $error = _check_subscriber($email, $id, $db_stl, $wild_cards);
|
||||
next if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
next if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $id }));
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
next unless ($data);
|
||||
|
||||
$db_sub->insert($data);
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $info = $DB->table('Lists')->get($cgi->{lid});
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $cgi->{lid}, GList::_load_global('site_title')) }) if (!$info);
|
||||
|
||||
$url_success = $info->{lst_url_subscribe_success} if ($info->{lst_url_subscribe_success});
|
||||
$url_failure = $info->{lst_url_subscribe_failure} if ($info->{lst_url_subscribe_failure});
|
||||
my $error = _check_subscriber($email, $info->{lst_id}, $db_stl, $wild_cards);
|
||||
return ('error_form.html', { msg => $error }) if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $cgi->{lid} })) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
unless ($data) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
$db_sub->insert($data);
|
||||
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
|
||||
print $IN->header( -url => $url_success );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_rm} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_rm {
|
||||
user_unsubscribe();
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_unsubscribe} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_unsubscribe {
|
||||
#-----------------------------------------------------------
|
||||
# Unsubscribe a email address
|
||||
#
|
||||
my $url_success = "$CFG->{static_url}/page/unsubscribe_success.html";
|
||||
my $url_failure = "$CFG->{static_url}/page/unsubscribe_failure.html";
|
||||
|
||||
my ($info, $email);
|
||||
# Gets hash from $IN? -> Global variable that's defined as what? I think it's the whole query parameter
|
||||
my $cgi = $IN->get_hash();
|
||||
# Get subscribers table -> We'll need this
|
||||
my $db_sub = $DB->table('Subscribers');
|
||||
# If lid is an array, return it as such, otherwise return the single array as an array
|
||||
my $lists = (ref $cgi->{lid} eq 'ARRAY') ? $cgi->{lid} : [$cgi->{lid}];
|
||||
# if this $cgi global has an eml_code (it should if cliked from a link)
|
||||
if ($cgi->{eml_code}) {
|
||||
# Get the e-mail Mailings table and then get the EML_CODE equal to this one
|
||||
# eml_code is equal to the hash that's sent -> Can use this again
|
||||
my $eml = $DB->table('EmailMailings')->get({ eml_code => $cgi->{eml_code} });
|
||||
# From the eml-code (hash), get the actual e-maile lowercased (this is probably a row)
|
||||
$email = lc $eml->{eml_email};
|
||||
}
|
||||
else {
|
||||
# Otherwise if not clicked from this, we're just going to try to get the e-mail from this instance
|
||||
$email = lc $cgi->{email};
|
||||
}
|
||||
|
||||
# If we don't have an e-mail, go to the failure url
|
||||
if (!$email or $#$lists < 0) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
# This looks like it gets at the meat
|
||||
|
||||
# make sure we have our SQL condition command
|
||||
require GT::SQL::Condition;
|
||||
|
||||
# Look/create new for sub_email with e-mail
|
||||
my $cd = GT::SQL::Condition->new(sub_email => '=' => $email);
|
||||
|
||||
# if we only have one entry in our list
|
||||
if ($#$lists == 0) {
|
||||
# From "Lists" get our value
|
||||
$info = $DB->table('Lists')->get($lists->[0]);
|
||||
# if no results, return an error
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $lists->[0]) }) if (!$info);
|
||||
|
||||
# depending on $info, go to success/failure ($info dpeendent failure/success)
|
||||
$url_success = $info->{lst_url_unsubscribe_success} if ($info->{lst_url_unsubscribe_success});
|
||||
$url_failure = $info->{lst_url_unsubscribe_failure} if ($info->{lst_url_unsubscribe_failure});
|
||||
|
||||
# to our foreign key list add this e-mail
|
||||
$cd->add(sub_list_id_fk => '=' => $lists->[0]);
|
||||
}
|
||||
else {
|
||||
# same thing as above, just do it if we have any in the list
|
||||
$cd->add(sub_list_id_fk => 'IN' => $lists);
|
||||
}
|
||||
|
||||
# if we didn't do any adding, go to the failure
|
||||
if (!$db_sub->count($cd)) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
# looks like this is in testing
|
||||
#------------demo code-----------
|
||||
# return ('user_success_form.html', { msg => GList::language('LOG_UNSUBS_SUCCESS', $info->{lst_title}) });
|
||||
|
||||
# from "Subscribers", delete this added unsubscription
|
||||
if ($db_sub->delete($cd)) {
|
||||
# from our #info get the unsubscribe tempalte
|
||||
if ($info->{lst_unsubs_template}) {
|
||||
# get the e-mail from this info and lowercase and send
|
||||
$info->{sub_email} = lc $cgi->{email};
|
||||
# now parse and unsubscribe
|
||||
my $unsubs_template = _parse($info, $info->{lst_unsubs_template});
|
||||
# from template, send the header/body of the unsubscription
|
||||
GList::send($unsubs_template->{head}, { text => $unsubs_template->{body} });
|
||||
}
|
||||
}
|
||||
# go to success
|
||||
print $IN->header( -url => $url_success );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_move} = __LINE__ . << 'END_OF_SUB';
|
||||
sub user_move {
|
||||
#-----------------------------------------------------------
|
||||
# Remove a subscription and then create a new one
|
||||
#
|
||||
#----------------------------------
|
||||
# First, let's get the list information we're moving
|
||||
#----------------------------------
|
||||
my $cgi = $IN->get_hash();
|
||||
my @values = split('-', $cgi->{from_to_lid});
|
||||
my $element_count = scalar(@values);
|
||||
|
||||
# If invalid params, return an error
|
||||
return ('error_form.html', { msg => GList::language('LOG_ERROR') }) unless ($element_count == 2);
|
||||
|
||||
my $unsub = $values[0];
|
||||
my $sub = $values[1];
|
||||
|
||||
#----------------------------------
|
||||
# Prepare the unsubscription and do so
|
||||
#----------------------------------
|
||||
$cgi->{lid} = $unsub;
|
||||
|
||||
my $url_success = "$CFG->{static_url}/page/unsubscribe_success.html";
|
||||
my $url_failure = "$CFG->{static_url}/page/unsubscribe_failure.html";
|
||||
|
||||
my ($info, $email);
|
||||
my $db_sub = $DB->table('Subscribers');
|
||||
my $lists = (ref $cgi->{lid} eq 'ARRAY') ? $cgi->{lid} : [$cgi->{lid}];
|
||||
if ($cgi->{eml_code}) {
|
||||
my $eml = $DB->table('EmailMailings')->get({ eml_code => $cgi->{eml_code} });
|
||||
$email = lc $eml->{eml_email};
|
||||
}
|
||||
else {
|
||||
$email = lc $cgi->{email};
|
||||
}
|
||||
|
||||
# If we don't have an e-mail, go to the failure url
|
||||
if (!$email or $#$lists < 0) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
|
||||
# Look/create new for sub_email with e-mail
|
||||
my $cd = GT::SQL::Condition->new(sub_email => '=' => $email);
|
||||
|
||||
# if we only have one entry in our list
|
||||
if ($#$lists == 0) {
|
||||
$info = $DB->table('Lists')->get($lists->[0]);
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $lists->[0]) }) if (!$info);
|
||||
|
||||
$url_success = $info->{lst_url_unsubscribe_success} if ($info->{lst_url_unsubscribe_success});
|
||||
$url_failure = $info->{lst_url_unsubscribe_failure} if ($info->{lst_url_unsubscribe_failure});
|
||||
|
||||
$cd->add(sub_list_id_fk => '=' => $lists->[0]);
|
||||
}
|
||||
else {
|
||||
$cd->add(sub_list_id_fk => 'IN' => $lists);
|
||||
}
|
||||
|
||||
if (!$db_sub->count($cd)) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
# Remove them from this list
|
||||
my $unsubs_template;
|
||||
if ($db_sub->delete($cd)) {
|
||||
# from our #info get the unsubscribe tempalte
|
||||
if ($info->{lst_unsubs_template}) {
|
||||
# get the e-mail from this info and lowercase and send
|
||||
$info->{sub_email} = lc $cgi->{email};
|
||||
# now parse and unsubscribe
|
||||
$unsubs_template = _parse($info, $info->{lst_unsubs_template});
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------
|
||||
# Success means we proceed with the subscription
|
||||
#----------------------------------
|
||||
|
||||
# Prepare the subscription and so so
|
||||
$cgi->{lid} = $sub;
|
||||
|
||||
# get subscribe success URLs
|
||||
$url_success = "$CFG->{static_url}/page/subscribe_success.html";
|
||||
$url_failure = "$CFG->{static_url}/page/subscribe_failure.html";
|
||||
my $demo = 0;
|
||||
# errors if we don't have an accurate list ID
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR') }) unless ($cgi->{lid});
|
||||
|
||||
# Get the relevant table lsits (Subscribers). StopLists is the unknown one--doesn't look like it's used anymore
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
|
||||
# if there's an array of IDs, loop over them
|
||||
if (ref $cgi->{lid} eq 'ARRAY') {
|
||||
foreach my $id (@{$cgi->{lid}}) {
|
||||
$info = $DB->table('Lists')->get($id);
|
||||
next unless ($info);
|
||||
|
||||
my $error = _check_subscriber($email, $id, $db_stl, $wild_cards);
|
||||
next if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
next if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $id }));
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
next unless ($data);
|
||||
|
||||
$db_sub->insert($data);
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$info = $DB->table('Lists')->get($cgi->{lid});
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $cgi->{lid}, GList::_load_global('site_title')) }) if (!$info);
|
||||
|
||||
$url_success = $info->{lst_url_subscribe_success} if ($info->{lst_url_subscribe_success});
|
||||
$url_failure = $info->{lst_url_subscribe_failure} if ($info->{lst_url_subscribe_failure});
|
||||
my $error = _check_subscriber($email, $info->{lst_id}, $db_stl, $wild_cards);
|
||||
return ('error_form.html', { msg => $error }) if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $cgi->{lid} })) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
unless ($data) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
$db_sub->insert($data);
|
||||
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
|
||||
if ($unsubs_template) {
|
||||
# from template, send the header/body of the unsubscription
|
||||
GList::send($unsubs_template->{head}, { text => $unsubs_template->{body} });
|
||||
}
|
||||
|
||||
print $IN->header( -url => $url_success );
|
||||
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_generate_info} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _generate_info {
|
||||
my ($info, $email, $name) = @_;
|
||||
my %data = ( sub_email => $email, sub_name => $name, sub_created => time, sub_list_id_fk => $info->{lst_id}, sub_user_id_fk => $info->{lst_user_id_fk} );
|
||||
$info->{sub_email} = $email;
|
||||
$info->{sub_name} = $name;
|
||||
|
||||
my $template;
|
||||
if ($info->{lst_opt}) {
|
||||
my $val_code = join '', ('a'..'z', 'A'..'Z', 0..9)[map rand(62), 1 .. 30];
|
||||
$data{sub_validated} = '0';
|
||||
$data{sub_val_code} = "GT$val_code";
|
||||
$info->{validate_code} = $val_code;
|
||||
$template = _parse($info, $info->{lst_opt_template});
|
||||
}
|
||||
elsif ($info->{lst_subs_template}) {
|
||||
$template = _parse($info, $info->{lst_subs_template});
|
||||
}
|
||||
return ($template, \%data);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_signup_check} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _signup_check {
|
||||
#-------------------------------------------------------------------
|
||||
#
|
||||
my $data = shift;
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $refix = $CFG->{signup_username_regex} || '^[\w\-\.]{3,}$';
|
||||
|
||||
length $data->{usr_username} < 3 and return GList::language('USR_SIGNUP_USERNAME_INVALID');
|
||||
$data->{usr_username} =~ /$refix/ or return GList::language('USR_INVALID');
|
||||
$db->count({ usr_username => $data->{usr_username} }) and return GList::language('USR_SIGNUP_USERNAME_TAKEN');
|
||||
length $data->{usr_password} < 4 and return GList::language('ADM_PWD_INVALID');
|
||||
$data->{usr_password} ne $data->{con_password} and return GList::language('USR_SIGNUP_CONFIRM_PASS');
|
||||
$data->{usr_email} =~ /.@\S+\.\S+$/ or return GList::language('USR_SIGNUP_EMAIL_INVALID', $data->{usr_email});
|
||||
$db->count({ usr_email => $data->{usr_email} }) and return GList::language('USR_SIGNUP_EMAIL_INUSE', $data->{usr_email});
|
||||
|
||||
if ($CFG->{signup_restricted_email} and ref $CFG->{signup_restricted_email} eq 'ARRAY') {
|
||||
foreach my $e (@{$CFG->{signup_restricted_email}}) {
|
||||
$data->{usr_email} eq $e and return GList::language('USR_SIGNUP_EMAIL_RESTRICTED', $data->{usr_email});
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_check_subscriber} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _check_subscriber {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
my ($email, $lst_id, $db_stl, $wild_cards) = @_;
|
||||
|
||||
# trim blank spaces
|
||||
if ($email) {
|
||||
$email =~ s,^\s+,,g;
|
||||
$email =~ s,\s+$,,g;
|
||||
}
|
||||
|
||||
return GList::language('USR_SUB_OVERLIMIT') if (GList::check_limit('sublist', $lst_id));
|
||||
return GList::language('USR_SUB_INVALID_EMAIL') if ($email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $email =~ /\s/ );
|
||||
return GList::language('USR_SUB_STOPLIST') if ($db_stl->count({ stl_email => $email }));
|
||||
foreach (@$wild_cards) {
|
||||
my $e = $_->[0];
|
||||
my $re = quotemeta $e;
|
||||
$re =~ s/\\\*/.*/;
|
||||
$re =~ s/\\\?/./;
|
||||
return GList::language('USR_SUB_STOPLIST') if ($email =~ /$re/i);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_parse} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _parse {
|
||||
#-----------------------------------------------------------
|
||||
# Load email template
|
||||
#
|
||||
my ($info, $name) = @_;
|
||||
|
||||
require GList::Template;
|
||||
my $db = $DB->table('EmailTemplates');
|
||||
my $template = $db->get({ tpl_user_id_fk => $info->{lst_user_id_fk}, tpl_name => $name });
|
||||
return if (!$template);
|
||||
|
||||
my $sth = $DB->table('Users')->select({ usr_username => $info->{lst_user_id_fk} });
|
||||
return unless $sth;
|
||||
|
||||
my $uinfo = $sth->fetchrow_hashref;
|
||||
@{$info}{keys %$uinfo} = (values %$uinfo);
|
||||
|
||||
foreach (keys %$template) {
|
||||
$template->{$_} = GList::Template->parse(
|
||||
"string",
|
||||
[$info],
|
||||
{
|
||||
string => $template->{$_},
|
||||
disable => { functions => 1 }
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
my $headers;
|
||||
if ($template->{tpl_extra}) {
|
||||
for (split /\s*\n\s*/, $template->{tpl_extra}) { # This will weed out any blank lines
|
||||
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
||||
$headers->{$key} = $value if $key and $value;
|
||||
}
|
||||
}
|
||||
$headers->{From} = $template->{tpl_from};
|
||||
$headers->{To} = $template->{tpl_to};
|
||||
$headers->{Subject} = $template->{tpl_subject};
|
||||
|
||||
return { body => $template->{tpl_body}, head => $headers };
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_parse_file} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _parse_file {
|
||||
my ($file, $info) = @_;
|
||||
require GT::Mail::Editor;
|
||||
require GList::Template;
|
||||
|
||||
my $tpl = GT::Mail::Editor->new( dir => "$CFG->{priv_path}/templates", template => $CFG->{template_set} );
|
||||
$tpl->load($file);
|
||||
|
||||
my %head;
|
||||
my $headers = $tpl->headers;
|
||||
while (my ($k, $v) = each %$headers) {
|
||||
my $val = $v;
|
||||
$val = GList::Template->parse(
|
||||
"string",
|
||||
[$info],
|
||||
{
|
||||
string => $val,
|
||||
disable => { functions => 1 }
|
||||
}
|
||||
);
|
||||
$head{$k} = $val;
|
||||
}
|
||||
my $body = GList::Template->parse(
|
||||
"string",
|
||||
[$info],
|
||||
{
|
||||
string => $tpl->{body},
|
||||
disable => { functions => 1 }
|
||||
}
|
||||
);
|
||||
return (\%head, $body);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_cleanup_files} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _cleanup_files {
|
||||
#----------------------------------------------------------
|
||||
# Clear out old temporary attachments.
|
||||
#
|
||||
my $second = $CFG->{session_exp} * 3600 || 3600;
|
||||
opendir (DIR, "$CFG->{priv_path}/tmp") or die GList::language('DIR_OPEN_ERR', "$CFG->{priv_path}/tmp");
|
||||
my @files = readdir(DIR);
|
||||
closedir (DIR);
|
||||
foreach my $file (@files) {
|
||||
my $full_file = "$CFG->{priv_path}/tmp/$file";
|
||||
next if ( -d $full_file );
|
||||
|
||||
if ( (-M _) * 86400 > $second ) {
|
||||
$full_file =~ /(.*)/;
|
||||
$full_file = $1;
|
||||
unlink $full_file;
|
||||
}
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_todo} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _todo {
|
||||
#---------------------------------------------------------------------------
|
||||
#
|
||||
my $do = shift;
|
||||
my %actions = (
|
||||
user_open => 1,
|
||||
user_click => 1,
|
||||
user_signup => 1,
|
||||
user_remind => 1,
|
||||
user_validate => 1,
|
||||
user_subscribe => 1,
|
||||
user_rm => 1,
|
||||
user_unsubscribe=> 1,
|
||||
user_account_validate => 1,
|
||||
# add in account updating
|
||||
user_move => 1
|
||||
);
|
||||
if (exists $actions{$do}) {
|
||||
return 1;
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _determine_action {
|
||||
#----------------------------------------------------------------------------
|
||||
# Check valid action
|
||||
#
|
||||
my $action = shift || undef;
|
||||
return if ( !$action );
|
||||
return 'user_login' if ( !$USER and !_todo($action) );
|
||||
|
||||
my %valid = (
|
||||
map { $_ => 1 } qw(
|
||||
user_open
|
||||
user_click
|
||||
user_signup
|
||||
user_login
|
||||
user_logout
|
||||
user_remind
|
||||
user_validate
|
||||
user_subscribe
|
||||
user_rm
|
||||
user_unsubscribe
|
||||
user_account_validate
|
||||
# Add in ability to update account
|
||||
user_move
|
||||
)
|
||||
);
|
||||
exists $valid{$action} and return $action;
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
63
site/glist/lib/GList/mod_perl.pm
Normal file
63
site/glist/lib/GList/mod_perl.pm
Normal file
@ -0,0 +1,63 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: mod_perl.pm,v 1.7 2004/09/13 23:12:25 jagerman 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::mod_perl;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/glist/lib';
|
||||
|
||||
# If under mod_perl, we use Apache::DBI to cache connections.
|
||||
use GT::Base qw/MOD_PERL/;
|
||||
BEGIN {
|
||||
require Apache::DBI if MOD_PERL;
|
||||
print STDERR "\nPreloading Gossamer List modules into mod_perl:\n\t"
|
||||
}
|
||||
|
||||
use GList();
|
||||
BEGIN { print STDERR " ." }
|
||||
|
||||
# Preload commonly used GT libs.
|
||||
use GT::CGI();
|
||||
use GT::Template();
|
||||
use GT::Dumper();
|
||||
use GT::Date();
|
||||
use GT::Mail();
|
||||
BEGIN { print STDERR " ." }
|
||||
use GT::SQL();
|
||||
use GT::SQL::Relation();
|
||||
|
||||
# Preload GList modules.
|
||||
BEGIN { print STDERR " ." }
|
||||
use GList::Authenticate();
|
||||
use GList::Admin();
|
||||
use GList::List();
|
||||
use GList::Mailer();
|
||||
use GList::Message();
|
||||
BEGIN { print STDERR " ." }
|
||||
use GList::Profile();
|
||||
use GList::SQL();
|
||||
use GList::Template();
|
||||
use GList::Tools();
|
||||
use GList::User();
|
||||
|
||||
BEGIN { print STDERR " .\nAll modules loaded ok!\n" };
|
||||
|
||||
print STDERR "Compiling all functions ...";
|
||||
|
||||
GT::AutoLoader::compile_all();
|
||||
|
||||
print STDERR " All modules compiled and loaded ok!\n\n";
|
||||
|
||||
1;
|
||||
306
site/glist/lib/GT/AutoLoader.pm
Normal file
306
site/glist/lib/GT/AutoLoader.pm
Normal file
@ -0,0 +1,306 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::AutoLoader
|
||||
# Author: Jason Rhinelander
|
||||
# $Id: AutoLoader.pm,v 1.13 2005/03/21 06:57:58 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::AutoLoader;
|
||||
|
||||
use vars qw($AUTOLOAD %LOG %PACKAGES);
|
||||
use strict qw/vars subs/; # no strict 'refs' - we need several soft references here.
|
||||
|
||||
sub import {
|
||||
shift; # Discard the package, as 'use GT::AutoLoader' calls GT::AutoLoader->import(ARGS)
|
||||
my %opts = @_;
|
||||
|
||||
my $pkg = caller;
|
||||
++$PACKAGES{$pkg};
|
||||
|
||||
if ($opts{LOG} and ref $opts{LOG} eq 'CODE') {
|
||||
$LOG{$pkg} = delete $opts{LOG}; # Everything that requests a log will get one for all modules
|
||||
}
|
||||
|
||||
delete $opts{NAME} if $opts{NAME} and $opts{NAME} eq 'AUTOLOAD'; # Allows "if ($opts{NAME})" later on.
|
||||
|
||||
my $COMPILE;
|
||||
*{$pkg . ($opts{NAME} ? "::$opts{NAME}" : '::AUTOLOAD')} = sub {
|
||||
if ($opts{NAME} or !$AUTOLOAD) { # If they're using another name, it most likely means they are wrapping the AUTOLOAD, which means we have to check for $AUTOLOAD in their package.
|
||||
$AUTOLOAD = ${$pkg . '::AUTOLOAD'};
|
||||
}
|
||||
my ($func) = $AUTOLOAD =~ /([^:]+)$/; # How odd - we use $GT::AutoLoader::AUTOLOAD, even though this is run in some other package
|
||||
|
||||
if ($COMPILE = \%{$pkg . '::COMPILE'}) {
|
||||
if (defined $COMPILE->{$func}) {
|
||||
for (keys %LOG) { $LOG{$_}->($pkg, $func, 'COMPILE') }
|
||||
|
||||
_compile($COMPILE, $pkg, $func);
|
||||
|
||||
$AUTOLOAD = '';
|
||||
|
||||
goto &{"$pkg\::$func"};
|
||||
}
|
||||
}
|
||||
|
||||
if ($opts{NEXT}) {
|
||||
my ($pack, $func) = $opts{NEXT} =~ /(?:(.+)::)?([^:]+?)$/;
|
||||
$pack ||= $pkg;
|
||||
${$pack . '::AUTOLOAD'} = $AUTOLOAD;
|
||||
my $next = "$pack\::$func";
|
||||
$AUTOLOAD = '';
|
||||
goto &$next;
|
||||
}
|
||||
|
||||
# It doesn't exist in %COMPILE, which means we have to look through @ISA for another AUTOLOAD to pass this to
|
||||
if (my @inh = @{"$pkg\::ISA"}) {
|
||||
while (my $inh = shift @inh) {
|
||||
my $al = $inh . '::AUTOLOAD';
|
||||
if (defined &$al) {
|
||||
$$al = "$pkg\::$func"; # Sets $Other::Package::AUTOLOAD
|
||||
$AUTOLOAD = '';
|
||||
goto &$al;
|
||||
}
|
||||
elsif (my @isa = @{$inh . '::ISA'}) {
|
||||
unshift @inh, @isa;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my ($file, $line) = (caller)[1,2];
|
||||
$AUTOLOAD = '';
|
||||
die "$pkg ($$, GT::AutoLoader): Unknown method '$func' called at $file line $line.\n";
|
||||
};
|
||||
|
||||
my $compile = "$pkg\::COMPILE";
|
||||
*$compile = \%$compile; # Implements "use vars qw/%COMPILE/" for you
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if ($^C) {
|
||||
eval <<'CHECK';
|
||||
sub CHECK {
|
||||
# ------------------------------------------------------------------------------
|
||||
# In Perl 5.6+ this allows you to do: perl -cMMy::Module -e0 to make sure all
|
||||
# your %COMPILE subs compile. In versions of Perl prior to 5.6, this is simply
|
||||
# treated as a sub named "CHECK", which is never called. $^C is also 5.6+
|
||||
# specific - whether or not you are running under "-c"
|
||||
compile_all();
|
||||
}
|
||||
CHECK
|
||||
}
|
||||
}
|
||||
|
||||
sub compile_all {
|
||||
my @pkg = @_;
|
||||
if (@pkg) {
|
||||
@pkg = grep +($PACKAGES{$_} or (warn "$_ is not loaded, does not use GT::AutoLoader, or is not a valid package" and 0)), @pkg;
|
||||
@pkg or die "No valid packages passed to compile_all()!";
|
||||
}
|
||||
else {
|
||||
@pkg = keys %PACKAGES;
|
||||
}
|
||||
|
||||
for my $pkg (@pkg) {
|
||||
my $COMPILE = \%{$pkg . '::COMPILE'} or next;
|
||||
for my $func (keys %$COMPILE) {
|
||||
_compile($COMPILE, $pkg, $func) if $COMPILE->{$func};
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _compile {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Compiles a subroutine from a module's %COMPILE into the module's package.
|
||||
# die()s if the subroutine cannot compile or still does not exist after
|
||||
# compiling. Takes three arguments: A reference to the packages %COMPILE hash,
|
||||
# the package, and the name of the function to load.
|
||||
#
|
||||
my ($COMPILE, $pkg, $func) = @_;
|
||||
|
||||
my $linenum = ($COMPILE->{$func} =~ s/^(\d+)//) ? $1+1 : 0;
|
||||
eval "package $pkg;\n#line $linenum$pkg\::$func\n$COMPILE->{$func}";
|
||||
if ($@) { die "Unable to load $pkg\::$func: $@" }
|
||||
if (not defined &{"$pkg\::$func"}) {
|
||||
die "Unable to load $pkg\::$func: Subroutine did not compile correctly (possible bad name).";
|
||||
}
|
||||
|
||||
undef $COMPILE->{$func}; # Leave the key in the compile hash so that things can test to see if it was defined in the compile hash
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::AutoLoader - load subroutines on demand
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package GT::Module;
|
||||
use GT::AutoLoader; # You now have an AUTOLOAD subroutine that will check for entries in %COMPILE
|
||||
|
||||
or
|
||||
|
||||
package GT::OtherModule;
|
||||
use GT::AutoLoader(NAME => '_AUTOLOAD'); # Import AUTOLOAD as _AUTOLOAD, define our own AUTOLOAD
|
||||
sub AUTOLOAD {
|
||||
...
|
||||
goto &_AUTOLOAD;
|
||||
}
|
||||
|
||||
then:
|
||||
|
||||
$COMPILE{sub} = __LINE__ . <<'END_OF_SUB';
|
||||
sub method_name {
|
||||
...
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<GT::AutoLoader> module works as a way to speed up your code. Currently,
|
||||
the only thing it does is scan for a %COMPILE hash in your package. If it finds
|
||||
it, it looks for the subroutine you called, and if found compiles and runs it.
|
||||
|
||||
If unable to find a subroutine to compile in %COMPILE, B<GT::AutoLoader> will
|
||||
scan your inheritance tree (@ISA) for another AUTOLOAD subroutine to pass this
|
||||
off to. If there isn't any, a fatal error occurs.
|
||||
|
||||
To use B<GT::AutoLoader>, in its standard behaviour, simply put:
|
||||
C<use GT::AutoLoader;> in your module. When you use GT::AutoLoader, two things
|
||||
will happen. First, an C<AUTOLOAD> subroutine will be imported into your
|
||||
namespace that will automatically compile your subroutines only when they are
|
||||
needed, thus speeding up compile time. Secondly, a %COMPILE hash will be defined
|
||||
in your package, eliminating the need for you to: use vars qw/%COMPILE/;
|
||||
|
||||
=head1 USE
|
||||
|
||||
You can pass options to GT::AutoLoader to change the behaviour of the module.
|
||||
Currently, logging is the only option, however more options (perhaps including
|
||||
a different compiling scheme) will be added at some future point.
|
||||
|
||||
Options are specified as import() arguments. For example:
|
||||
|
||||
use GT::AutoLoader(OPTION => "value");
|
||||
|
||||
=over 4
|
||||
|
||||
=item NAME
|
||||
|
||||
If you want to import the autoload subroutine as something other than
|
||||
'Package::AUTOLOAD', the 'NAME' option should be used. Its value is the name
|
||||
to import as. For example, to import a GT::AutoLoader AUTOLOAD named _AUTOLOAD
|
||||
(this is useful when declaring your own AUTOLOAD behaviour, but still using
|
||||
GT::AutoLoader's behaviour as a fallback), you would do something like:
|
||||
|
||||
use GT::AutoLoader(NAME => '_AUTOLOAD');
|
||||
|
||||
=item LOG
|
||||
|
||||
Takes a code reference as its value. The code reference will be called three
|
||||
arguments - the package name, the name of the function, and the autoload method
|
||||
(Currently only 'COMPILE'). Note that this will be called for ALL autoloaded
|
||||
subroutines, not just the ones in your package.
|
||||
|
||||
WARNING - you cannot put code in your log that relies on autoloaded methods -
|
||||
you'll end up throwing the program into an infinite loop.
|
||||
|
||||
For example, to get a line of debugging after each subroutine is compiled, you
|
||||
could C<use GT::AutoLoader> like this:
|
||||
|
||||
use GT::AutoLoader(LOG => sub {
|
||||
print "Compiled $_[1] in package $_[0]\n"
|
||||
});
|
||||
|
||||
=item NEXT
|
||||
|
||||
Normally, GT::AutoLoader will look for another AUTOLOAD to call in your
|
||||
package's @ISA inheritance tree. You can alter this behaviour and tell
|
||||
GT::AutoLoader what to call next using the NEXT option.
|
||||
|
||||
For example, if you have a sub _AUTOLOAD { } that you wanted to call if the
|
||||
method isn't found by GT::AutoLoader, you would use GT::AutoLoader like this:
|
||||
|
||||
use GT::AutoLoader(NEXT => 'Package::Name::_AUTOLOAD');
|
||||
|
||||
The _AUTOLOAD function in your package will now be called if GT::AutoLoader
|
||||
can't load the method on its own. $AUTOLOAD will be set for you in whichever
|
||||
package the function you provide is in. Note that if you simply want to use an
|
||||
inherited AUTOLOAD, you B<should not> use this option; GT::AutoLoader will
|
||||
handle that just fine on its own.
|
||||
|
||||
You may omit the package (Package::Name::) if the function is in your current
|
||||
package.
|
||||
|
||||
=back
|
||||
|
||||
=head1 compile_all
|
||||
|
||||
A function exists in GT::AutoLoader to compile all %COMPILE-subroutines. By
|
||||
default (without arguments) compile_all() compiles every %COMPILE-subroutine in
|
||||
every package that has used GT::AutoLoader. You can, however, pass in a list of
|
||||
packages which compile_all() will check instead of compiling everything. Note
|
||||
that GT::AutoLoader will only compile %COMPILE-subroutines in packages that
|
||||
have used GT::AutoLoader, so if you specify package "Foo", but "Foo" hasn't
|
||||
used GT::AutoLoader, it will be ignored.
|
||||
|
||||
You can do something like:
|
||||
|
||||
GT::AutoLoader::compile_all(__PACKAGE__) if MOD_PERL;
|
||||
|
||||
to have a GT::AutoLoader compile every %COMPILE-subroutine in the current
|
||||
package automatically under mod_perl, or you could add this code to your
|
||||
mod_perl startup file or test script:
|
||||
|
||||
GT::AutoLoader::compile_all;
|
||||
|
||||
Test scripts should definately use compile_all() to ensure that all subroutines
|
||||
compile correctly!
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
None.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Due to the nature of Perl's AUTOLOAD handling, you must take care when using
|
||||
GT::AutoLoader in a subclass. In short, subclassed methods B<MUST NOT> be put
|
||||
into the %COMPILE hash.
|
||||
|
||||
The problem is that since the subroutine does not exist in the package, Perl,
|
||||
while decending the inheritance tree, will not see it but will probably see the
|
||||
parent's method (unless nothing else has called the method, but you should
|
||||
never count on that), and call it rather than looking for your package's
|
||||
AUTOLOAD.
|
||||
|
||||
This isn't to say that subclasses cannot use AUTOLOAD - just that subclasses
|
||||
cannot use autoloaded methods (%COMPILE-subroutines) if a method of the same
|
||||
name exists in the parent class. Autoloaded function calls are not affected.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Base>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: AutoLoader.pm,v 1.13 2005/03/21 06:57:58 jagerman Exp $
|
||||
|
||||
=cut
|
||||
949
site/glist/lib/GT/Base.pm
Normal file
949
site/glist/lib/GT/Base.pm
Normal file
@ -0,0 +1,949 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Base.pm,v 1.132 2005/06/22 19:59:25 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base module that handles common functions like initilization,
|
||||
# debugging, etc. Should not be used except as a base class.
|
||||
#
|
||||
|
||||
package GT::Base;
|
||||
# ===============================================================
|
||||
require 5.004; # We need perl 5.004 for a lot of the OO features.
|
||||
|
||||
use strict qw/vars subs/; # No refs as we do some funky stuff.
|
||||
use vars qw/$AUTOLOAD $DEBUG $VERSION $ATTRIB_CACHE %ERRORS @EXPORT_OK %EXPORT_TAGS @ISA/;
|
||||
use GT::AutoLoader(NEXT => 'GT::Base::_AUTOLOAD');
|
||||
use Exporter();
|
||||
|
||||
# We need to inherit from Exporter for ->require_version support
|
||||
@ISA = qw/Exporter/;
|
||||
|
||||
BEGIN {
|
||||
if ($ENV{MOD_PERL}) {
|
||||
eval { require mod_perl2 } or eval { require mod_perl };
|
||||
}
|
||||
require CGI::SpeedyCGI if $CGI::SpeedyCGI::i_am_speedy or $CGI::SpeedyCGI::_i_am_speedy;
|
||||
}
|
||||
use constants
|
||||
MOD_PERL => $ENV{MOD_PERL} ? $mod_perl2::VERSION || $mod_perl::VERSION : 0,
|
||||
SPEEDY => $CGI::SpeedyCGI::_i_am_speedy || $CGI::SpeedyCGI::i_am_speedy ? $CGI::SpeedyCGI::VERSION : 0;
|
||||
use constants
|
||||
PERSIST => MOD_PERL || SPEEDY;
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.132 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIB_CACHE = {};
|
||||
%ERRORS = (
|
||||
MKDIR => "Could not make directory '%s': %s",
|
||||
OPENDIR => "Could not open directory '%s': %s",
|
||||
RMDIR => "Could not remove directory '%s': %s",
|
||||
CHMOD => "Could not chmod '%s': %s",
|
||||
UNLINK => "Could not unlink '%s': %s",
|
||||
READOPEN => "Could not open '%s' for reading: %s",
|
||||
WRITEOPEN => "Could not open '%s' for writing: %s",
|
||||
OPEN => "Could not open '%s': %s",
|
||||
BADARGS => "Wrong argument passed to this subroutine. %s"
|
||||
);
|
||||
@EXPORT_OK = qw/MOD_PERL SPEEDY PERSIST $MOD_PERL $SPEEDY $PERSIST/;
|
||||
%EXPORT_TAGS = (
|
||||
all => \@EXPORT_OK,
|
||||
persist => [qw/MOD_PERL SPEEDY PERSIST/]
|
||||
);
|
||||
|
||||
# These three are for backwards-compatibility with what GT::Base used to
|
||||
# export; new code should import and use the constants of the same name.
|
||||
use vars qw/$MOD_PERL $SPEEDY $PERSIST/;
|
||||
$MOD_PERL = MOD_PERL;
|
||||
$SPEEDY = SPEEDY;
|
||||
$PERSIST = PERSIST;
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------
|
||||
# Create a base object and use set or init to initilize anything.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
|
||||
# Create self with our debug value.
|
||||
my $self = { _debug => defined ${"$class\:\:DEBUG"} ? ${"$class\:\:DEBUG"} : $DEBUG };
|
||||
bless $self, $class;
|
||||
$self->debug("Created new $class object.") if $self->{_debug} > 2;
|
||||
|
||||
# Set initial attributes, and then run init function or call set.
|
||||
$self->reset;
|
||||
if ($self->can('init')) {
|
||||
$self->init(@_);
|
||||
}
|
||||
else {
|
||||
$self->set(@_) if (@_);
|
||||
}
|
||||
|
||||
if (index($self, 'HASH') != -1) {
|
||||
$self->{_debug} = $self->{debug} if $self->{debug};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# -------------------------------------------------------
|
||||
# Object is nuked.
|
||||
#
|
||||
(index($_[0], 'HASH') > -1) or return;
|
||||
if ($_[0]->{_debug} and $_[0]->{_debug} > 2) {
|
||||
my ($package, $filename, $line) = caller;
|
||||
$_[0]->debug("Destroyed $_[0] in package $package at $filename line $line.");
|
||||
}
|
||||
}
|
||||
|
||||
sub _AUTOLOAD {
|
||||
# -------------------------------------------------------
|
||||
# We use autoload to provide an accessor/setter for all
|
||||
# attributes.
|
||||
#
|
||||
my ($self, $param) = @_;
|
||||
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
|
||||
|
||||
# If this is a known attribute, return/set it and save the function
|
||||
# to speed up future calls.
|
||||
my $autoload_attrib = 0;
|
||||
if (ref $self and index($self, 'HASH') != -1 and exists $self->{$attrib} and not exists $COMPILE{$attrib}) {
|
||||
$autoload_attrib = 1;
|
||||
}
|
||||
else {
|
||||
# Class method possibly.
|
||||
unless (ref $self) {
|
||||
my $attribs = $ATTRIB_CACHE->{$self} || _get_attribs($self);
|
||||
if (exists $attribs->{$attrib}) {
|
||||
$autoload_attrib = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
# This is an accessor, create a function for it.
|
||||
if ($autoload_attrib) {
|
||||
*{$AUTOLOAD} = sub {
|
||||
unless (ref $_[0]) { # Class Method
|
||||
my $attribs = $ATTRIB_CACHE->{$_[0]} || _get_attribs($_[0]);
|
||||
if (@_ > 1) {
|
||||
$_[0]->debug("Setting base attribute '$attrib' => '$_[1]'.") if defined ${$_[0] . '::DEBUG'} and ${$_[0] . '::DEBUG'} > 2;
|
||||
$ATTRIB_CACHE->{$_[0]}->{$attrib} = $_[1];
|
||||
}
|
||||
return $ATTRIB_CACHE->{$_[0]}->{$attrib};
|
||||
}
|
||||
if (@_ > 1) { # Instance Method
|
||||
$_[0]->debug("Setting '$attrib' => '$_[1]'.") if $_[0]->{_debug} and $_[0]->{_debug} > 2;
|
||||
$_[0]->{$attrib} = $_[1];
|
||||
}
|
||||
return $_[0]->{$attrib};
|
||||
};
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
# Otherwise we have an error, let's help the user out and try to
|
||||
# figure out what they were doing.
|
||||
_generate_fatal($self, $attrib, $param);
|
||||
}
|
||||
|
||||
sub set {
|
||||
# -------------------------------------------------------
|
||||
# Set one or more attributes.
|
||||
#
|
||||
return unless (@_);
|
||||
if ( !ref $_[0]) { class_set(@_); }
|
||||
else {
|
||||
my $self = shift;
|
||||
my $p = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', "Argument to set must be either hash, hash ref, array, array ref or CGI object.");
|
||||
my $attribs = $ATTRIB_CACHE->{ref $self} || _get_attribs(ref $self);
|
||||
my $f = 0;
|
||||
$self->{_debug} = $p->{debug} || 0 if exists $p->{debug};
|
||||
foreach my $attrib (keys %$attribs) {
|
||||
next unless exists $p->{$attrib};
|
||||
$self->debug("Setting '$attrib' to '${$p}{$attrib}'.") if $self->{_debug} and $self->{_debug} > 2;
|
||||
$self->{$attrib} = $p->{$attrib};
|
||||
$f++;
|
||||
}
|
||||
return $f;
|
||||
}
|
||||
}
|
||||
|
||||
sub common_param {
|
||||
# -------------------------------------------------------
|
||||
# Expects to find $self, followed by one or more arguments of
|
||||
# unknown types. Converts them to hash refs.
|
||||
#
|
||||
shift;
|
||||
my $out = {};
|
||||
return $out unless @_ and defined $_[0];
|
||||
CASE: {
|
||||
(ref $_[0] eq 'HASH') and do { $out = shift; last CASE };
|
||||
(UNIVERSAL::can($_[0], 'get_hash')) and do { $out = $_[0]->get_hash; last CASE };
|
||||
(UNIVERSAL::can($_[0], 'param')) and do { foreach ($_[0]->param) { my @vals = $_[0]->param($_); $out->{$_} = (@vals > 1) ? \@vals : $vals[0]; } last CASE };
|
||||
(defined $_[0] and not @_ % 2) and do { $out = {@_}; last CASE };
|
||||
return;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub reset {
|
||||
# -------------------------------------------------------
|
||||
# Resets all attribs in $self.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
my $attrib = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
||||
|
||||
# Deep copy hash and array refs only.
|
||||
while (my ($k, $v) = each %$attrib) {
|
||||
unless (ref $v) {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$self->{$k} = {};
|
||||
foreach my $k1 (keys %{$attrib->{$k}}) {
|
||||
$self->{$k}->{$k1} = $attrib->{$k}->{$k1};
|
||||
}
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$self->{$k} = [];
|
||||
foreach my $v1 (@{$attrib->{$k}}) {
|
||||
push @{$self->{$k}}, $v1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _get_attribs {
|
||||
# -------------------------------------------------------
|
||||
# Searches through ISA and returns this packages attributes.
|
||||
#
|
||||
my $class = shift;
|
||||
my $attrib = defined ${"$class\:\:ATTRIBS"} ? ${"$class\:\:ATTRIBS"} : {};
|
||||
my @pkg_isa = defined @{"$class\:\:ISA"} ? @{"$class\:\:ISA"} : ();
|
||||
|
||||
foreach my $pkg (@pkg_isa) {
|
||||
next if $pkg eq 'Exporter'; # Don't mess with Exporter.
|
||||
next if $pkg eq 'GT::Base';
|
||||
my $fattrib = defined ${"${pkg}::ATTRIBS"} ? ${"${pkg}::ATTRIBS"} : next;
|
||||
foreach (keys %{$fattrib}) {
|
||||
$attrib->{$_} = $fattrib->{$_} unless exists $attrib->{$_};
|
||||
}
|
||||
}
|
||||
$ATTRIB_CACHE->{$class} = $attrib;
|
||||
return $attrib;
|
||||
}
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub debug {
|
||||
# -------------------------------------------------------
|
||||
# Displays a debugging message.
|
||||
#
|
||||
my ($self, $msg) = @_;
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
# Add line numbers if asked for.
|
||||
if ($msg !~ /\r?\n$/) {
|
||||
my ($package, $file, $line) = caller;
|
||||
$msg .= " at $file line $line.\n";
|
||||
}
|
||||
# Remove windows linefeeds (breaks unix terminals).
|
||||
$msg =~ s/\r//g unless ($^O eq 'MSWin32');
|
||||
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
||||
print STDERR "$pkg ($$): $msg";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{debug_level} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub debug_level {
|
||||
# -------------------------------------------------------
|
||||
# Set the debug level for either the class or object.
|
||||
#
|
||||
if (ref $_[0]) {
|
||||
$_[0]->{_debug} = shift if @_ > 1;
|
||||
return $_[0]->{_debug};
|
||||
}
|
||||
else {
|
||||
my $pkg = shift;
|
||||
if (@_) {
|
||||
my $level = shift;
|
||||
${"${pkg}::DEBUG"} = $level;
|
||||
}
|
||||
return ${"${pkg}::DEBUG"};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{warn} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub warn { shift->error(shift, WARN => @_) }
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{fatal} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub fatal { shift->error(shift, FATAL => @_) }
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{error} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub error {
|
||||
# -------------------------------------------------------
|
||||
# Error handler.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($msg, $level, @args) = @_;
|
||||
my $pkg = ref $self || $self;
|
||||
$level = defined $level ? $level : 'FATAL';
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
|
||||
# Load the ERROR messages.
|
||||
$self->set_basic_errors;
|
||||
|
||||
# err_pkg stores the package just before the users program for displaying where the error was raised
|
||||
# think simplified croak.
|
||||
my $err_pkg = $pkg;
|
||||
if ($is_hash) {
|
||||
$err_pkg = defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg;
|
||||
}
|
||||
|
||||
# initilize vars to silence -w warnings.
|
||||
# msg_pkg stores which package error messages are stored, defaults to self, but doesn't have to be.
|
||||
${$pkg . '::ERROR_MESSAGE'} ||= '';
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
my $debug = $is_hash ? $self->{_debug} : ${$pkg . "::DEBUG"};
|
||||
|
||||
# cls_err stores the actual error hash (error_code => error_string). Initilize to prevent -w
|
||||
# warnings.
|
||||
${$msg_pkg . '::ERRORS'} ||= {};
|
||||
${$pkg . '::ERRORS'} ||= {};
|
||||
my $cls_err = ${$msg_pkg . '::ERRORS'};
|
||||
my $pkg_err = ${$pkg . '::ERRORS'} || $pkg;
|
||||
my %messages = %$cls_err;
|
||||
foreach (keys %$pkg_err) { $messages{$_} = $pkg_err->{$_}; }
|
||||
|
||||
# Return current error if not called with arguments.
|
||||
if ($is_hash) {
|
||||
$self->{_error} ||= [];
|
||||
if (@_ == 0) {
|
||||
my @err = @{$self->{_error}} ? @{$self->{_error}} : (${$msg_pkg . "::error"});
|
||||
return wantarray ? @err : defined($err[0]) ? $err[0] : undef;
|
||||
}
|
||||
}
|
||||
elsif (@_ == 0) {
|
||||
return ${$msg_pkg . '::errcode'};
|
||||
}
|
||||
|
||||
# Set a subroutine that will clear out the error class vars, and self vars under mod_perl.
|
||||
$self->register_persistent_cleanup(sub { $self->_cleanup_obj($msg_pkg, $is_hash) });
|
||||
|
||||
# store the error code.
|
||||
${$msg_pkg . '::errcode'} ||= '';
|
||||
${$msg_pkg . '::errcode'} = $msg;
|
||||
${$msg_pkg . '::errargs'} ||= '';
|
||||
if ($is_hash) {
|
||||
$self->{_errcode} = $msg;
|
||||
$self->{_errargs} = @args ? [@args] : [];
|
||||
}
|
||||
|
||||
# format the error message.
|
||||
if (keys %messages) {
|
||||
if (exists $messages{$msg}) {
|
||||
$msg = $messages{$msg};
|
||||
}
|
||||
$msg = $msg->(@args) if ref $msg eq 'CODE'; # Pass the sprintf arguments to the code ref
|
||||
$msg = @args ? sprintf($msg, map { defined $_ ? $_ : '[undefined]' } @args) : $msg;
|
||||
|
||||
$msg =~ s/\r\n?/\n/g unless $^O eq 'MSWin32';
|
||||
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
||||
}
|
||||
|
||||
# set the formatted error to $msg_pkg::error.
|
||||
push @{$self->{_error}}, $msg if ($is_hash);
|
||||
|
||||
# If we have a fatal error, then we either send it to error_handler if
|
||||
# the user has a custom handler, or print our message and die.
|
||||
|
||||
# Initialize $error to silence -w warnings.
|
||||
${$msg_pkg . '::error'} ||= '';
|
||||
if (uc $level eq 'FATAL') {
|
||||
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? _format_err($err_pkg, \$msg) : _format_err($err_pkg, $msg);
|
||||
|
||||
die(_format_err($err_pkg, $msg)) if in_eval();
|
||||
if (exists($SIG{__DIE__}) and $SIG{__DIE__}) {
|
||||
die _format_err($err_pkg, $msg);
|
||||
}
|
||||
else {
|
||||
print STDERR _format_err($err_pkg, $msg);
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
# Otherwise we set the error message, and print it if we are in debug mode.
|
||||
elsif (uc $level eq 'WARN') {
|
||||
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? \$msg : $msg;
|
||||
my $warning = _format_err($err_pkg, $msg);
|
||||
$debug and (
|
||||
$SIG{__WARN__}
|
||||
? CORE::warn $warning
|
||||
: print STDERR $warning
|
||||
);
|
||||
$debug and $debug > 1 and (
|
||||
$SIG{__WARN__}
|
||||
? CORE::warn stack_trace('GT::Base',1)
|
||||
: print STDERR stack_trace('GT::Base',1)
|
||||
);
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_cleanup_obj} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _cleanup_obj {
|
||||
# -------------------------------------------------------
|
||||
# Cleans up the self object under a persitant env.
|
||||
#
|
||||
my ($self, $msg_pkg, $is_hash) = @_;
|
||||
|
||||
${$msg_pkg . '::errcode'} = undef;
|
||||
${$msg_pkg . '::error'} = undef;
|
||||
${$msg_pkg . '::errargs'} = undef;
|
||||
if ($is_hash) {
|
||||
defined $self and $self->{_errcode} = undef;
|
||||
defined $self and $self->{_error} = undef;
|
||||
defined $self and $self->{_errargs} = undef;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{errcode} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub errcode {
|
||||
# -------------------------------------------------------
|
||||
# Returns the last error code generated.
|
||||
#
|
||||
my $self = shift;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
if (ref $self and $is_hash) {
|
||||
return $self->{_errcode};
|
||||
}
|
||||
else {
|
||||
return ${$msg_pkg . '::errcode'};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{errargs} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub errargs {
|
||||
# -------------------------------------------------------
|
||||
# Returns the arguments from the last error. In list
|
||||
# context returns an array, in scalar context returns
|
||||
# an array reference.
|
||||
#
|
||||
my $self = shift;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
my $ret = [];
|
||||
if (ref $self and $is_hash) {
|
||||
$self->{_errargs} ||= [];
|
||||
$ret = $self->{_errargs};
|
||||
}
|
||||
else {
|
||||
${$msg_pkg . '::errcode'} ||= [];
|
||||
$ret = ${$msg_pkg . '::errargs'};
|
||||
}
|
||||
return wantarray ? @{$ret} : $ret;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{clear_errors} = __LINE__ . <<'END_OF_SUB';
|
||||
sub clear_errors {
|
||||
# -------------------------------------------------------
|
||||
# Clears the error stack
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{_error} = [];
|
||||
$self->{_errargs} = [];
|
||||
$self->{_errcode} = undef;
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{set_basic_errors} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub set_basic_errors {
|
||||
# -------------------------------------------------------
|
||||
# Sets basic error messages commonly used.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self || $self;
|
||||
if (${$class . '::ERROR_MESSAGE'}) {
|
||||
$class = ${$class . '::ERROR_MESSAGE'};
|
||||
}
|
||||
${$class . '::ERRORS'} ||= {};
|
||||
my $err = ${$class . '::ERRORS'};
|
||||
for my $key (keys %ERRORS) {
|
||||
$err->{$key} = $ERRORS{$key} unless exists $err->{$key};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{whatis} = __LINE__ . <<'END_OF_SUB';
|
||||
sub whatis {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a package name and returns a list of all packages inherited from, in
|
||||
# the order they would be checked by Perl, _including_ the package passed in.
|
||||
# The argument may be an object or a string, and this method can be called as
|
||||
# a function, class method, or instance method. When called as a method, the
|
||||
# argument is optional - if omitted, the class name will be used.
|
||||
# Duplicate classes are _not_ included.
|
||||
#
|
||||
shift if @_ > 1;
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
my @isa = $class;
|
||||
my %found;
|
||||
my $pstash;
|
||||
for (my $c = 0; $c < @isa; $c++) {
|
||||
my $is = $isa[$c];
|
||||
my @parts = split /::/, $is;
|
||||
my $pstash = $::{shift(@parts) . "::"};
|
||||
while (defined $pstash and @parts) {
|
||||
$pstash = $pstash->{shift(@parts) . "::"};
|
||||
}
|
||||
if (defined $pstash and $pstash->{ISA} and my @is = @{*{\$pstash->{ISA}}{ARRAY}}) {
|
||||
splice @isa, $c + 1, 0,
|
||||
grep $_ eq $class
|
||||
? die "Recursive inheritance detected in package $class"
|
||||
: !$found{$_}++,
|
||||
@is;
|
||||
}
|
||||
}
|
||||
@isa
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{in_eval} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub in_eval {
|
||||
# -------------------------------------------------------
|
||||
# Current perl has a variable for it, old perl, we need to look
|
||||
# through the stack trace. Ugh.
|
||||
#
|
||||
my $ineval;
|
||||
if ($] >= 5.005 and !MOD_PERL) { $ineval = defined($^S) ? $^S : (stack_trace('GT::Base',1) =~ /\(eval\)/) }
|
||||
elsif (MOD_PERL) {
|
||||
my $stack = stack_trace('GT::Base', 1);
|
||||
$ineval = $stack =~ m{
|
||||
\(eval\)
|
||||
(?!
|
||||
\s+called\ at\s+
|
||||
(?:
|
||||
/dev/null
|
||||
|
|
||||
-e
|
||||
|
|
||||
/\S*/(?:Apache2?|ModPerl)/(?:Registry(?:Cooker)?|PerlRun)\.pm
|
||||
|
|
||||
PerlHandler\ subroutine\ `(?:Apache2?|ModPerl)::Registry
|
||||
)
|
||||
)
|
||||
}x;
|
||||
}
|
||||
else {
|
||||
my $stack = stack_trace('GT::Base', 1);
|
||||
$ineval = $stack =~ /\(eval\)/;
|
||||
}
|
||||
return $ineval;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{register_persistent_cleanup} = __LINE__ . <<'END_OF_SUB';
|
||||
sub register_persistent_cleanup {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a code reference and registers it for cleanup under mod_perl and
|
||||
# SpeedyCGI. Has no effect when not under those environments.
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
ref(my $code = shift) eq 'CODE'
|
||||
or __PACKAGE__->fatal(BADARGS => 'Usage: GT::Base->register_persistent_cleanup($coderef)');
|
||||
|
||||
if (MOD_PERL and MOD_PERL >= 1.999022) { # Final mod_perl 2 API
|
||||
require Apache2::ServerUtil;
|
||||
if (Apache2::ServerUtil::restart_count() != 1) {
|
||||
require Apache2::RequestUtil;
|
||||
require APR::Pool;
|
||||
Apache2::RequestUtil->request->pool->cleanup_register($code);
|
||||
}
|
||||
}
|
||||
elsif (MOD_PERL and MOD_PERL >= 1.99) { # mod_perl 2 API prior to 2.0.0-RC5
|
||||
require Apache2;
|
||||
require Apache::ServerUtil;
|
||||
if (Apache::ServerUtil::restart_count() != 1) {
|
||||
require APR::Pool;
|
||||
Apache->request->pool->cleanup_register($code);
|
||||
}
|
||||
}
|
||||
elsif (MOD_PERL and $Apache::Server::Starting != 1) {
|
||||
require Apache;
|
||||
Apache->request->register_cleanup($code);
|
||||
}
|
||||
elsif (SPEEDY) {
|
||||
CGI::SpeedyCGI->new->register_cleanup($code);
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{class_set} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub class_set {
|
||||
# -------------------------------------------------------
|
||||
# Set the class init attributes.
|
||||
#
|
||||
my $pkg = shift;
|
||||
my $attribs = $ATTRIB_CACHE->{$pkg} || _get_attribs($pkg);
|
||||
|
||||
if (ref $attribs ne 'HASH') { return; }
|
||||
|
||||
# Figure out what we were passed in.
|
||||
my $out = GT::Base->common_param(@_) or return;
|
||||
|
||||
# Set the attribs.
|
||||
foreach (keys %$out) {
|
||||
exists $attribs->{$_} and ($attribs->{$_} = $out->{$_});
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{attrib} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub attrib {
|
||||
# -------------------------------------------------------
|
||||
# Returns a list of attributes.
|
||||
#
|
||||
my $class = ref $_[0] || $_[0];
|
||||
my $attribs = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
||||
return wantarray ? %$attribs : $attribs;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{stack_trace} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub stack_trace {
|
||||
# -------------------------------------------------------
|
||||
# If called with arguments, returns stack trace, otherwise
|
||||
# prints to stdout/stderr depending on whether in cgi or not.
|
||||
#
|
||||
my $pkg = shift || 'Unknown';
|
||||
my $raw = shift || 0;
|
||||
my $rollback = shift || 3;
|
||||
my ($ls, $spc, $fh);
|
||||
if ($raw) {
|
||||
if (defined $ENV{REQUEST_METHOD}) {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
}
|
||||
}
|
||||
elsif (defined $ENV{REQUEST_METHOD}) {
|
||||
print STDOUT "Content-type: text/html\n\n";
|
||||
$ls = '<br>';
|
||||
$spc = ' ';
|
||||
$fh = \*STDOUT;
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
$fh = \*STDERR;
|
||||
}
|
||||
my $out = $raw ? '' : "${ls}STACK TRACE$ls======================================$ls";
|
||||
{
|
||||
package DB;
|
||||
my $i = $rollback;
|
||||
local $@;
|
||||
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
|
||||
my @args;
|
||||
for (@DB::args) {
|
||||
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
||||
my $print = $@ ? \$_ : $_;
|
||||
push @args, defined $print ? $print : '[undef]';
|
||||
}
|
||||
if (@args) {
|
||||
my $args = join ", ", @args;
|
||||
$args =~ s/\n\s*\n/\n/g;
|
||||
$args =~ s/\n/\n$spc$spc$spc$spc/g;
|
||||
$out .= qq!$pkg ($$): $sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
|
||||
}
|
||||
else {
|
||||
$out .= qq!$pkg ($$): $sub called at $file line $line with no arguments.$ls!;
|
||||
}
|
||||
}
|
||||
}
|
||||
$raw ? return $out : print $fh $out;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_format_err} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _format_err {
|
||||
# -------------------------------------------------------
|
||||
# Formats an error message for output.
|
||||
#
|
||||
my ($pkg, $msg) = @_;
|
||||
my ($file, $line) = get_file_line($pkg);
|
||||
return "$pkg ($$): $msg at $file line $line.\n";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{get_file_line} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub get_file_line {
|
||||
# -------------------------------------------------------
|
||||
# Find out what line error was generated in.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $pkg = shift || scalar caller;
|
||||
my %pkg;
|
||||
for (whatis($pkg)) {
|
||||
$pkg{$_}++;
|
||||
}
|
||||
my ($i, $last_pkg);
|
||||
while (my $pack = caller($i++)) {
|
||||
if ($pkg{$pack}) {
|
||||
$last_pkg = $i;
|
||||
}
|
||||
elsif ($last_pkg) {
|
||||
last; # We're one call back beyond the package being looked for
|
||||
}
|
||||
}
|
||||
unless (defined $last_pkg) {
|
||||
# You messed up by trying to pass in a package that was never called
|
||||
GT::Base->fatal("get_file_line() called with an invalid package ($pkg)");
|
||||
}
|
||||
(undef, my ($file, $line)) = caller($last_pkg);
|
||||
|
||||
return ($file, $line);
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_generate_fatal} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _generate_fatal {
|
||||
# -------------------------------------------------------------------
|
||||
# Generates a fatal error caused by misuse of AUTOLOAD.
|
||||
#
|
||||
my ($self, $attrib, $param) = @_;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
my @poss;
|
||||
if (UNIVERSAL::can($self, 'debug_level') and $self->debug_level) {
|
||||
my @class = @{$pkg . '::ISA'} || ();
|
||||
unshift @class, $pkg;
|
||||
for (@class) {
|
||||
my @subs = keys %{$_ . '::'};
|
||||
my %compiled = %{$_ . '::COMPILE'};
|
||||
for (keys %compiled) {
|
||||
push @subs, $_ if defined $compiled{$_};
|
||||
}
|
||||
for my $routine (@subs) {
|
||||
next if $attrib eq $routine;
|
||||
next unless $self;
|
||||
next unless defined $compiled{$_} or UNIVERSAL::can($self, $routine);
|
||||
if (GT::Base->_sndex($attrib) eq GT::Base->_sndex($routine)) {
|
||||
push @poss, $routine;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Generate an error message, with possible alternatives and die.
|
||||
my $err_pkg = $is_hash ? (defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg) : $pkg;
|
||||
my ($call_pkg, $file, $line) = caller(1);
|
||||
my $msg = @poss
|
||||
? " Perhaps you meant to call " . join(", or " => @poss) . ".\n"
|
||||
: '';
|
||||
die "$err_pkg ($$): Unknown method '$attrib' called at $file line $line.\n$msg";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_sndex} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _sndex {
|
||||
# -------------------------------------------------------
|
||||
# Do a soundex lookup to suggest alternate methods the person
|
||||
# might have wanted.
|
||||
#
|
||||
my $self = shift;
|
||||
local $_ = shift;
|
||||
my $search_sound = uc;
|
||||
$search_sound =~ tr/A-Z//cd;
|
||||
if ($search_sound eq '') { $search_sound = 0 }
|
||||
else {
|
||||
my $f = substr($search_sound, 0, 1);
|
||||
$search_sound =~ tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/;
|
||||
my $fc = substr($search_sound, 0, 1);
|
||||
$search_sound =~ s/^$fc+//;
|
||||
$search_sound =~ tr///cs;
|
||||
$search_sound =~ tr/0//d;
|
||||
$search_sound = $f . $search_sound . '000';
|
||||
$search_sound = substr($search_sound, 0, 4);
|
||||
}
|
||||
return $search_sound;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Base - Common base module to be inherited by all classes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Base;
|
||||
use vars qw/@ISA $ATTRIBS $ERRORS/
|
||||
@ISA = qw/GT::Base/;
|
||||
$ATTRIBS = {
|
||||
accessor => default,
|
||||
accessor2 => default,
|
||||
};
|
||||
$ERRORS = {
|
||||
BADARGS => "Invalid argument: %s passed to subroutine: %s",
|
||||
};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Base is a base class that is used to provide common error handling,
|
||||
debugging, creators and accessor methods.
|
||||
|
||||
To use GT::Base, simply make your module inherit from GT::Base. That
|
||||
will provide the following functionality:
|
||||
|
||||
=head2 Debugging
|
||||
|
||||
Two new methods are available for debugging:
|
||||
|
||||
$self->debug($msg, [DEBUG_LEVEL]);
|
||||
|
||||
This will send a $msg to STDERR if the current debug level is greater
|
||||
then the debug level passed in (defaults to 1).
|
||||
|
||||
$self->debug_level(DEBUG_LEVEL);
|
||||
Class->debug_level(DEBUG_LEVEL);
|
||||
|
||||
You can call debug_level() to set or get the debug level. It can
|
||||
be set per object by calling it as an object method, or class wide
|
||||
which will initilize all new objects with that debug level (only if
|
||||
using the built in creator).
|
||||
|
||||
The debugging uses a package variable:
|
||||
|
||||
$Class::DEBUG = 0;
|
||||
|
||||
and assumes it exists.
|
||||
|
||||
=head2 Error Handling
|
||||
|
||||
Your object can now generate errors using the method:
|
||||
|
||||
$self->error(CODE, LEVEL, [args]);
|
||||
|
||||
CODE should be a key to a hash of error codes to user readable
|
||||
error messages. This hash should be stored in $ERRORS which is
|
||||
defined in your pacakge, or the package named in $ERROR_MESSAGE.
|
||||
|
||||
LEVEL should be either 'FATAL' or 'WARN'. If not specified it defaults
|
||||
to FATAL. If it's a fatal error, the program will print the message
|
||||
to STDERR and die.
|
||||
|
||||
args can be used to format the error message. For instance, you can
|
||||
defined commonly used errors like:
|
||||
|
||||
CANTOPEN => "Unable to open file: '%s': %s"
|
||||
|
||||
in your $ERRORS hash. Then you can call error like:
|
||||
|
||||
open FILE, "somefile.txt"
|
||||
or return $self->error(CANTOPEN => FATAL => "somefile.txt", "$!");
|
||||
|
||||
The error handler will format your message using sprintf(), so all
|
||||
regular printf formatting strings are allowed.
|
||||
|
||||
Since errors are kept within an array, too many errors can pose a
|
||||
memory problem. To clear the error stack simply call:
|
||||
|
||||
$self->clear_errors();
|
||||
|
||||
=head2 Error Trapping
|
||||
|
||||
You can specify at run time to trap errors.
|
||||
|
||||
$self->catch_errors(\&code_ref);
|
||||
|
||||
which sets a $SIG{__DIE__} handler. Any fatal errors that occur, will
|
||||
run your function. The function will not be run if the fatal was thrown
|
||||
inside of an eval though.
|
||||
|
||||
=head2 Stack Trace
|
||||
|
||||
You can print out a stack trace at any time by using:
|
||||
|
||||
$self->stack_trace(1);
|
||||
Class->stack_trace(1);
|
||||
|
||||
If you pass in 1, the stack trace will be returned as a string, otherwise
|
||||
it will be printed to STDOUT.
|
||||
|
||||
=head2 Accessor Methods
|
||||
|
||||
Using GT::Base automatically provides accessor methods for all your
|
||||
attributes. By specifying:
|
||||
|
||||
$ATTRIBS = {
|
||||
attrib => 'default',
|
||||
...
|
||||
};
|
||||
|
||||
in your package, you can now call:
|
||||
|
||||
my $val = $obj->attrib();
|
||||
$obj->attrib($set_val);
|
||||
|
||||
to set and retrieve the attributes for that value.
|
||||
|
||||
Note: This uses AUTOLOAD, so if you implement AUTOLOAD in your package,
|
||||
you must have it fall back to GT::Base::AUTOLOAD if it fails. This
|
||||
can be done with:
|
||||
|
||||
AUTOLOAD {
|
||||
...
|
||||
goto >::Base::AUTOLOAD;
|
||||
}
|
||||
|
||||
which will pass all arguments as well.
|
||||
|
||||
=head2 Parameter Parsing
|
||||
|
||||
GT::Base also provides a method to parse parameters. In your methods you
|
||||
can do:
|
||||
|
||||
my $self = shift;
|
||||
my $parm = $self->common_param(@_);
|
||||
|
||||
This will convert any of a hash reference, hash or CGI object into a hash
|
||||
reference.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Base.pm,v 1.132 2005/06/22 19:59:25 jagerman Exp $
|
||||
|
||||
=cut
|
||||
838
site/glist/lib/GT/CGI.pm
Normal file
838
site/glist/lib/GT/CGI.pm
Normal file
@ -0,0 +1,838 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: CGI.pm,v 1.145 2005/06/21 21:02:57 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements CGI.pm's CGI functionality, but faster.
|
||||
#
|
||||
|
||||
package GT::CGI;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::Base(':persist'); # Imports MOD_PERL, SPEEDY and PERSIST
|
||||
use vars qw/@ISA $DEBUG $VERSION $ATTRIBS $ERRORS $PRINTED_HEAD $EOL
|
||||
$FORM_PARSED %PARAMS @PARAMS %COOKIES @EXPORT_OK %EXPORT_TAGS/;
|
||||
use GT::AutoLoader;
|
||||
require Exporter;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.145 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
nph => 0,
|
||||
p => ''
|
||||
};
|
||||
$ERRORS = {
|
||||
INVALIDCOOKIE => "Invalid cookie passed to header: %s",
|
||||
INVALIDDATE => "Date '%s' is not a valid date format.",
|
||||
};
|
||||
|
||||
$EOL = ($^O eq 'MSWin32') ? "\n" : "\015\012"; # IIS has problems with \015\012 on nph scripts.
|
||||
$PRINTED_HEAD = 0;
|
||||
$FORM_PARSED = 0;
|
||||
%PARAMS = ();
|
||||
@PARAMS = ();
|
||||
%COOKIES = ();
|
||||
@EXPORT_OK = qw/escape unescape html_escape html_unescape/;
|
||||
%EXPORT_TAGS = (
|
||||
escape => [qw/escape unescape html_escape html_unescape/]
|
||||
);
|
||||
|
||||
# Pre load our compiled if under mod_perl/speedy.
|
||||
if (PERSIST) {
|
||||
require GT::CGI::Cookie;
|
||||
require GT::CGI::MultiPart;
|
||||
require GT::CGI::Fh;
|
||||
}
|
||||
|
||||
sub load_data {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Loads the form information into PARAMS. Data comes from either a multipart
|
||||
# form, a GET Request, a POST request, or as arguments from command line.
|
||||
#
|
||||
my $self = shift;
|
||||
unless ($FORM_PARSED) {
|
||||
|
||||
# If we are under mod_perl we let mod_perl know that it should call reset_env
|
||||
# when a request is finished.
|
||||
GT::Base->register_persistent_cleanup(\&reset_env);
|
||||
|
||||
# Reset all the cache variables
|
||||
%PARAMS = @PARAMS = %COOKIES = ();
|
||||
|
||||
# Load form data.
|
||||
my $method = defined $ENV{REQUEST_METHOD} ? uc $ENV{REQUEST_METHOD} : '';
|
||||
my $content_length = defined $ENV{'CONTENT_LENGTH'} ? $ENV{'CONTENT_LENGTH'} : 0;
|
||||
|
||||
if ($method eq 'GET' or $method eq 'HEAD') {
|
||||
$self->parse_str(defined $ENV{QUERY_STRING} ? $ENV{QUERY_STRING} : '');
|
||||
}
|
||||
elsif ($method eq 'POST') {
|
||||
if ($content_length) {
|
||||
if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /^multipart/) {
|
||||
require GT::CGI::MultiPart;
|
||||
GT::CGI::MultiPart->parse($self);
|
||||
}
|
||||
else {
|
||||
read(STDIN, my $data, $content_length, 0);
|
||||
$data =~ s/\r?\n/&/g;
|
||||
$self->parse_str($data);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $data = join "&", @ARGV;
|
||||
$self->parse_str($data);
|
||||
}
|
||||
|
||||
# Load cookies.
|
||||
if (defined $ENV{HTTP_COOKIE}) {
|
||||
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
||||
/(.*)=(.*)/ or next;
|
||||
my ($key, $val) = (unescape($1), unescape($2));
|
||||
$val = [split '&', $val];
|
||||
$self->{cookies}->{$key} = $val;
|
||||
}
|
||||
}
|
||||
else {
|
||||
%{$self->{cookies}} = ();
|
||||
}
|
||||
|
||||
# Parse form buttons, allowing you to pass in name="foo=bar;a=b;c=d" as a name
|
||||
# tag in the form.
|
||||
for (keys %{$self->{params}}) {
|
||||
if (index($_, '=') >= 0) {
|
||||
next if substr($_, -2) eq '.y';
|
||||
(my $key = $_) =~ s/\.x$//;
|
||||
$self->parse_str($key);
|
||||
}
|
||||
}
|
||||
|
||||
# Save the data for caching
|
||||
while (my ($k, $v) = each %{$self->{params}}) {
|
||||
push @{$PARAMS{$k}}, @$v;
|
||||
}
|
||||
while (my ($k, $v) = each %{$self->{cookies}}) {
|
||||
push @{$COOKIES{$k}}, @$v;
|
||||
}
|
||||
@PARAMS = @{$self->{param_order} || []};
|
||||
|
||||
# Make sure the form is not parsed again during this request
|
||||
$FORM_PARSED = 1;
|
||||
}
|
||||
else { # Load the data from the cache
|
||||
while (my ($k, $v) = each %PARAMS) {
|
||||
push @{$self->{params}->{$k}}, @$v;
|
||||
}
|
||||
while (my ($k, $v) = each %COOKIES) {
|
||||
push @{$self->{cookies}->{$k}}, @$v;
|
||||
}
|
||||
$self->{param_order} = [@PARAMS];
|
||||
}
|
||||
|
||||
|
||||
$self->{data_loaded} = 1;
|
||||
}
|
||||
|
||||
sub class_new {
|
||||
# --------------------------------------------------------------------------------
|
||||
# Creates an object to be used for all class methods, this affects the global
|
||||
# cookies and params.
|
||||
#
|
||||
my $self = bless {} => shift;
|
||||
$self->load_data unless $self->{data_loaded};
|
||||
|
||||
$self->{cookies} = \%COOKIES;
|
||||
$self->{params} = \%PARAMS;
|
||||
$self->{param_order} = \@PARAMS;
|
||||
|
||||
for (keys %{$ATTRIBS}) { $self->{$_} = $ATTRIBS->{$_} }
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub reset_env {
|
||||
# --------------------------------------------------------------------------------
|
||||
# Reset the global environment.
|
||||
#
|
||||
%PARAMS = @PARAMS = %COOKIES = ();
|
||||
$PRINTED_HEAD = $FORM_PARSED = 0;
|
||||
1;
|
||||
}
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Called from GT::Base when a new object is created.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# If we are passed a single argument, then we load our data from
|
||||
# the input.
|
||||
if (@_ == 1) {
|
||||
my $p = $_[0];
|
||||
if (ref $p eq 'GT::CGI') {
|
||||
$p = $p->query_string;
|
||||
}
|
||||
$self->parse_str($p ? "&$p" : "");
|
||||
if (defined $ENV{HTTP_COOKIE}) {
|
||||
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
||||
/(.*)=(.*)/ or next;
|
||||
my ($key, $val) = (unescape($1), unescape($2));
|
||||
$val = [split '&', $val];
|
||||
$self->{cookies}->{$key} = $val;
|
||||
}
|
||||
}
|
||||
$self->{data_loaded} = 1;
|
||||
$FORM_PARSED = 1;
|
||||
}
|
||||
elsif (@_) {
|
||||
$self->set(@_);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{get_hash} = __LINE__ . <<'END_OF_SUB';
|
||||
sub get_hash {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Returns the parameters as a HASH, with multiple values becoming an array
|
||||
# reference.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $join = defined $_[0] ? $_[0] : 0;
|
||||
|
||||
keys %{$self->{params}} or return {};
|
||||
|
||||
# Construct hash ref and return it
|
||||
my $opts = {};
|
||||
foreach (keys %{$self->{params}}) {
|
||||
my @vals = @{$self->{params}->{$_}};
|
||||
$opts->{$_} = @vals > 1 ? \@vals : $vals[0];
|
||||
}
|
||||
return $opts;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{delete} = __LINE__ . <<'END_OF_SUB';
|
||||
sub delete {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Remove an element from the parameters.
|
||||
#
|
||||
my ($self, $param) = @_;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my @ret;
|
||||
if (exists $self->{params}->{$param}) {
|
||||
@ret = @{delete $self->{params}->{$param}};
|
||||
for (my $i = 0; $i < @{$self->{param_order}}; $i++) {
|
||||
if ($self->{param_order}->[$i] eq $param) {
|
||||
splice @{$self->{param_order}}, $i, 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
return wantarray ? @ret : $ret[0];
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{cookie} = __LINE__ . <<'END_OF_SUB';
|
||||
sub cookie {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Creates a new cookie for the user, implemented just like CGI.pm.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
if (@_ == 0) { # Return keys.
|
||||
return keys %{$self->{cookies}};
|
||||
}
|
||||
elsif (@_ == 1) { # Return value of param passed in.
|
||||
my $param = shift;
|
||||
return unless defined $param and $self->{cookies}->{$param};
|
||||
return wantarray ? @{$self->{cookies}->{$param}} : $self->{cookies}->{$param}->[0];
|
||||
}
|
||||
elsif (@_ == 2) {
|
||||
require GT::CGI::Cookie;
|
||||
return GT::CGI::Cookie->new(-name => $_[0], -value => $_[1]);
|
||||
}
|
||||
elsif (@_ % 2 == 0) {
|
||||
my %data = @_;
|
||||
if (exists $data{'-value'}) {
|
||||
require GT::CGI::Cookie;
|
||||
return GT::CGI::Cookie->new(%data);
|
||||
}
|
||||
}
|
||||
$self->fatal("Invalid arguments to cookie()");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub param {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Mimick CGI's param function for get/set.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
if (@_ == 0) { # Return keys in the same order they were provided
|
||||
return @{$self->{param_order} || []};
|
||||
}
|
||||
elsif (@_ == 1) { # Return value of param passed in.
|
||||
my $param = shift;
|
||||
return unless (defined($param) and $self->{params}->{$param});
|
||||
return wantarray ? @{$self->{params}->{$param}} : $self->{params}->{$param}->[0];
|
||||
}
|
||||
else { # Set parameter.
|
||||
my ($param, $value) = @_;
|
||||
unless ($self->{params}->{$param}) {
|
||||
# If we're not replacing/changing a parameter, we need to add the param to param_order
|
||||
push @{$self->{param_order}}, $param;
|
||||
}
|
||||
$self->{params}->{$param} = [ref $value eq 'ARRAY' ? @$value : $value];
|
||||
}
|
||||
}
|
||||
|
||||
sub header {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Mimick the header function.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
my %p = (ref($_[0]) eq 'HASH') ? %{$_[0]} : ( @_ % 2 ) ? () : @_;
|
||||
my @headers;
|
||||
|
||||
# Don't print headers twice unless -force'd.
|
||||
return '' if not delete $p{-force} and $PRINTED_HEAD;
|
||||
|
||||
# Start by adding NPH headers if requested.
|
||||
if ($self->{nph} || $p{-nph}) {
|
||||
if ($p{-url}) {
|
||||
push @headers, "HTTP/1.0 302 Moved";
|
||||
}
|
||||
else {
|
||||
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
|
||||
unless (MOD_PERL) {
|
||||
push @headers, "$protocol 200 OK";
|
||||
}
|
||||
}
|
||||
}
|
||||
delete $p{-nph};
|
||||
|
||||
# If requested, add a "Pragma: no-cache"
|
||||
my $no_cache = $p{'no-cache'} || $p{'-no-cache'};
|
||||
delete @p{qw/no-cache -no-cache/};
|
||||
if ($no_cache) {
|
||||
require GT::Date;
|
||||
push @headers,
|
||||
"Expires: Tue, 25 Jan 2000 12:00:00 GMT",
|
||||
"Last-Modified: " . GT::Date::date_get_gm(time, "%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% GMT"),
|
||||
"Cache-Control: no-cache",
|
||||
"Pragma: no-cache";
|
||||
}
|
||||
|
||||
# Add any cookies, we accept either an array of cookies
|
||||
# or a single cookie.
|
||||
my $add_date = 0;
|
||||
my $cookies = 0;
|
||||
my $container = delete($p{-cookie}) || '';
|
||||
require GT::CGI::Cookie if $container;
|
||||
if (ref $container and UNIVERSAL::isa($container, 'GT::CGI::Cookie')) {
|
||||
my $c = $container->cookie_header;
|
||||
push @headers, $c;
|
||||
$add_date = 1;
|
||||
$cookies++;
|
||||
}
|
||||
elsif (ref $container eq 'ARRAY') {
|
||||
foreach my $cookie (@$container) {
|
||||
next unless (defined $cookie and (ref $cookie eq 'GT::CGI::Cookie'));
|
||||
push @headers, $cookie->cookie_header;
|
||||
$add_date = 1;
|
||||
$cookies++;
|
||||
}
|
||||
}
|
||||
elsif ($container) {
|
||||
$self->error('INVALIDCOOKIE', 'WARN', $container);
|
||||
}
|
||||
|
||||
# Print expiry if requested.
|
||||
if (defined(my $expires = delete $p{-expires})) {
|
||||
require GT::CGI::Cookie;
|
||||
my $date = GT::CGI::Cookie->format_date(' ', $expires);
|
||||
unless ($date) {
|
||||
$self->error('INVALIDDATE', 'WARN', $expires);
|
||||
}
|
||||
else {
|
||||
push @headers, "Expires: $date";
|
||||
$add_date = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# Add a Date header if we printed an expires tag or a cookie tag.
|
||||
if ($add_date) {
|
||||
require GT::CGI::Cookie;
|
||||
my $now = GT::CGI::Cookie->format_date(' ');
|
||||
push @headers, "Date: $now";
|
||||
}
|
||||
|
||||
# Add Redirect Header.
|
||||
my $iis_redirect;
|
||||
if (my $url = delete $p{-url}) {
|
||||
if ($ENV{SERVER_SOFTWARE} =~ m|IIS/(\d+)|i and ($cookies or $1 >= 6)) {
|
||||
$iis_redirect = $url;
|
||||
}
|
||||
else {
|
||||
push @headers, "Location: $url";
|
||||
}
|
||||
}
|
||||
|
||||
# Add the Content-type header.
|
||||
my $type = @_ == 1 && !ref($_[0]) ? $_[0] : delete($p{-type}) || 'text/html';
|
||||
push @headers, "Content-type: $type";
|
||||
|
||||
# Add any custom headers.
|
||||
foreach my $key (keys %p) {
|
||||
$key =~ /^\s*-?(.+)/;
|
||||
push @headers, escape(ucfirst $1) . ": " . (ref $p{$key} eq 'SCALAR' ? ${$p{$key}} : escape($p{$key}));
|
||||
}
|
||||
$PRINTED_HEAD = 1;
|
||||
|
||||
my $headers = join($EOL, @headers) . $EOL . $EOL;
|
||||
|
||||
# Fun hack for IIS
|
||||
if ($iis_redirect) {
|
||||
$iis_redirect =~ y/;/&/; # You can't have semicolons in a meta http-equiv tag.
|
||||
return $headers . <<END_OF_HTML;
|
||||
<html><head><title>Document Moved</title><meta http-equiv="refresh" content="0;URL=$iis_redirect"></head>
|
||||
<body><noscript><h1>Object Moved</h1>This document may be found <a HREF="$iis_redirect">here</a></noscript></body></html>
|
||||
END_OF_HTML
|
||||
}
|
||||
return $headers;
|
||||
}
|
||||
|
||||
$COMPILE{redirect} = __LINE__ . <<'END_OF_SUB';
|
||||
sub redirect {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Print a redirect header.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
|
||||
my (@headers, $url);
|
||||
if (@_ == 0) {
|
||||
return $self->header({ -url => $self->self_url });
|
||||
}
|
||||
elsif (@_ == 1) {
|
||||
return $self->header({ -url => shift });
|
||||
}
|
||||
else {
|
||||
my $opts = ref $_[0] eq 'HASH' ? shift : {@_};
|
||||
$opts->{'-url'} ||= $opts->{'-URL'} || $self->self_url;
|
||||
return $self->header($opts);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub unescape {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns the url decoded string of the passed argument. Optionally takes an
|
||||
# array reference of multiple strings to decode. The values of the array are
|
||||
# modified directly, so you shouldn't need the return (which is the same array
|
||||
# reference).
|
||||
#
|
||||
my $todecode = pop;
|
||||
return unless defined $todecode;
|
||||
for my $str (ref $todecode eq 'ARRAY' ? @$todecode : $todecode) {
|
||||
$str =~ tr/+/ /; # pluses become spaces
|
||||
$str =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
|
||||
}
|
||||
$todecode;
|
||||
}
|
||||
|
||||
$COMPILE{escape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub escape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# return the url encoded string of the passed argument
|
||||
#
|
||||
my $toencode = pop;
|
||||
return unless defined $toencode;
|
||||
$toencode =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
|
||||
return $toencode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{html_escape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html_escape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Return the string html_escaped.
|
||||
#
|
||||
my $toencode = pop;
|
||||
return unless defined $toencode;
|
||||
if (ref($toencode) eq 'SCALAR') {
|
||||
$$toencode =~ s/&/&/g;
|
||||
$$toencode =~ s/</</g;
|
||||
$$toencode =~ s/>/>/g;
|
||||
$$toencode =~ s/"/"/g;
|
||||
$$toencode =~ s/'/'/g;
|
||||
}
|
||||
else {
|
||||
$toencode =~ s/&/&/g;
|
||||
$toencode =~ s/</</g;
|
||||
$toencode =~ s/>/>/g;
|
||||
$toencode =~ s/"/"/g;
|
||||
$toencode =~ s/'/'/g;
|
||||
}
|
||||
return $toencode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{html_unescape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html_unescape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Return the string html unescaped.
|
||||
#
|
||||
my $todecode = pop;
|
||||
return unless defined $todecode;
|
||||
if (ref $todecode eq 'SCALAR') {
|
||||
$$todecode =~ s/</</g;
|
||||
$$todecode =~ s/>/>/g;
|
||||
$$todecode =~ s/"/"/g;
|
||||
$$todecode =~ s/'/'/g;
|
||||
$$todecode =~ s/&/&/g;
|
||||
}
|
||||
else {
|
||||
$todecode =~ s/</</g;
|
||||
$todecode =~ s/>/>/g;
|
||||
$todecode =~ s/"/"/g;
|
||||
$todecode =~ s/'/'/g;
|
||||
$todecode =~ s/&/&/g;
|
||||
}
|
||||
return $todecode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{self_url} = __LINE__ . <<'END_OF_SUB';
|
||||
sub self_url {
|
||||
# -------------------------------------------------------------------
|
||||
# Return full URL with query options as CGI.pm
|
||||
#
|
||||
return $_[0]->url(query_string => 1, absolute => 1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{url} = __LINE__ . <<'END_OF_SUB';
|
||||
sub url {
|
||||
# -------------------------------------------------------------------
|
||||
# Return the current url. Can be called as GT::CGI->url() or $cgi->url().
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $opts = $self->common_param(@_);
|
||||
|
||||
my $absolute = exists $opts->{absolute} ? $opts->{absolute} : 0;
|
||||
my $query_string = exists $opts->{query_string} ? $opts->{query_string} : 1;
|
||||
my $path_info = exists $opts->{path_info} ? $opts->{path_info} : 0;
|
||||
my $remove_empty = exists $opts->{remove_empty} ? $opts->{remove_empty} : 0;
|
||||
if ($opts->{relative}) {
|
||||
$absolute = 0;
|
||||
}
|
||||
|
||||
my $url = '';
|
||||
my $script = $ENV{SCRIPT_NAME} || $0;
|
||||
my ($path, $prog) = $script =~ m,^(.+?)[/\\]?([^/\\]*)$,;
|
||||
|
||||
if ($absolute) {
|
||||
my ($protocol, $version) = split('/', $ENV{SERVER_PROTOCOL} || 'HTTP/1.0');
|
||||
$url = lc $protocol . "://";
|
||||
|
||||
my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME} || '';
|
||||
$url .= $host;
|
||||
|
||||
$path =~ s,^[/\\]*|[/\\]*$,,g;
|
||||
$url .= "/$path/";
|
||||
}
|
||||
$prog =~ s,^[/\\]*|[/\\]*$,,g;
|
||||
$url .= $prog;
|
||||
|
||||
if ($path_info and $ENV{PATH_INFO}) {
|
||||
my $path = $ENV{PATH_INFO};
|
||||
if (defined $ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ /IIS/) {
|
||||
$path =~ s/\Q$ENV{SCRIPT_NAME}//;
|
||||
}
|
||||
$url .= $path;
|
||||
}
|
||||
if ($query_string) {
|
||||
my $qs = $self->query_string( remove_empty => $remove_empty );
|
||||
if ($qs) {
|
||||
$url .= "?" . $qs;
|
||||
}
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{query_string} = __LINE__ . <<'END_OF_SUB';
|
||||
sub query_string {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the query string url escaped.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $opts = $self->common_param(@_);
|
||||
my $qs = '';
|
||||
foreach my $key (@{$self->{param_order} || []}) {
|
||||
my $esc_key = escape($key);
|
||||
foreach my $val (@{$self->{params}->{$key}}) {
|
||||
next if ($opts->{remove_empty} and ($val eq ''));
|
||||
$qs .= $esc_key . "=" . escape($val) . ";";
|
||||
}
|
||||
}
|
||||
$qs and chop $qs;
|
||||
$qs ? return $qs : return '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{browser_info} = __LINE__ . <<'END_OF_SUB';
|
||||
sub browser_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# my %tags = browser_info();
|
||||
# --------------------------
|
||||
# Returns various is_BROWSER, BROWSER_version tags.
|
||||
#
|
||||
return unless $ENV{HTTP_USER_AGENT};
|
||||
|
||||
my %browser_opts;
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} =~ m{Opera(?:\s+|/)(\d+\.\d+)}i) {
|
||||
$browser_opts{is_opera} = 1;
|
||||
$browser_opts{opera_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i) {
|
||||
$browser_opts{is_ie} = 1;
|
||||
$browser_opts{ie_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Mozilla/(\d+\.\d+)\s+\([^)]*rv:(\d+\.\d+)}i) {
|
||||
if ($1 >= 5.0) {
|
||||
$browser_opts{is_mozilla} = 1;
|
||||
$browser_opts{mozilla_version} = $2;
|
||||
}
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Safari/(\d+(?:\.\d+)?)}i) {
|
||||
$browser_opts{is_safari} = 1;
|
||||
$browser_opts{safari_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Konqueror/(\d+\.\d+)}i) {
|
||||
$browser_opts{is_konqueror} = 1;
|
||||
$browser_opts{konqueror_version} = $1;
|
||||
}
|
||||
return %browser_opts;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub parse_str {
|
||||
#--------------------------------------------------------------------------------
|
||||
# parses a query string and add it to the parameter list
|
||||
#
|
||||
my $self = shift;
|
||||
my @input;
|
||||
for (split /[;&]/, shift) {
|
||||
my ($key, $val) = /([^=]+)=(.*)/ or next;
|
||||
|
||||
# Need to remove cr's on windows.
|
||||
if ($^O eq 'MSWin32') {
|
||||
$key =~ s/%0D%0A/%0A/gi; # \x0d = \r, \x0a = \n
|
||||
$val =~ s/%0D%0A/%0A/gi;
|
||||
}
|
||||
push @input, $key, $val;
|
||||
}
|
||||
unescape(\@input);
|
||||
while (@input) {
|
||||
my ($k, $v) = splice @input, 0, 2;
|
||||
$self->{params}->{$k} or push @{$self->{param_order}}, $k;
|
||||
unshift @{$self->{params}->{$k}}, $v;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::CGI - a lightweight replacement for CGI.pm
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::CGI;
|
||||
my $in = new GT::CGI;
|
||||
foreach my $param ($in->param) {
|
||||
print "VALUE: $param => ", $in->param($param), "\n";
|
||||
}
|
||||
|
||||
use GT::CGI qw/-no_parse_buttons/;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::CGI is a lightweight replacement for CGI.pm. It implements most of the
|
||||
functionality of CGI.pm, with the main difference being that GT::CGI does not
|
||||
provide a function-based interface (with the exception of the escape/unescape
|
||||
functions, which can be called as either function or method), nor does it
|
||||
provide the HTML functionality provided by CGI.pm.
|
||||
|
||||
The primary motivation for this is to provide a CGI module that can be shipped
|
||||
with Gossamer products, not having to depend on a recent version of CGI.pm
|
||||
being installed on remote servers. The secondary motivation is to provide a
|
||||
module that loads and runs faster, thus speeding up Gossamer products.
|
||||
|
||||
Credit and thanks goes to the author of CGI.pm. A lot of the code (especially
|
||||
file upload) was taken from CGI.pm.
|
||||
|
||||
=head2 param - Accessing form input.
|
||||
|
||||
Can be called as either a class method or object method. When called with no
|
||||
arguments a list of keys is returned.
|
||||
|
||||
When called with a single argument in scalar context the first (and possibly
|
||||
only) value is returned. When called in list context an array of values is
|
||||
returned.
|
||||
|
||||
When called with two arguments, it sets the key-value pair.
|
||||
|
||||
=head2 header() - Printing HTTP headers
|
||||
|
||||
Can be called as a class method or object method. When called with no
|
||||
arguments, simply returns the HTTP header.
|
||||
|
||||
Other options include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -force => 1
|
||||
|
||||
Force printing of header even if it has already been displayed.
|
||||
|
||||
=item -type => 'text/plain'
|
||||
|
||||
Set the type of the header to something other then text/html.
|
||||
|
||||
=item -cookie => $cookie
|
||||
|
||||
Display any cookies. You can pass in a single GT::CGI::Cookie object, or an
|
||||
array of them.
|
||||
|
||||
=item -nph => 1
|
||||
|
||||
Display full headers for nph scripts.
|
||||
|
||||
=back
|
||||
|
||||
If called with a single argument, sets the Content-Type.
|
||||
|
||||
=head2 redirect - Redirecting to new URL.
|
||||
|
||||
Returns a Location: header to redirect a user.
|
||||
|
||||
=head2 cookie - Set/Get HTTP Cookies.
|
||||
|
||||
Sets or gets a cookie. To retrieve a cookie:
|
||||
|
||||
my $cookie = $cgi->cookie ('key');
|
||||
my $cookie = $cgi->cookie (-name => 'key');
|
||||
|
||||
or to retrieve a hash of all cookies:
|
||||
|
||||
my $cookies = $cgi->cookie;
|
||||
|
||||
To set a cookie:
|
||||
|
||||
$c = $cgi->cookie (-name => 'foo', -value => 'bar')
|
||||
|
||||
You can also specify -expires for when the cookie should expire, -path for
|
||||
which path the cookie valid, -domain for which domain the cookie is valid, and
|
||||
-secure if the cookie is only valid for secure sites.
|
||||
|
||||
You would then set the cookie by passing it to the header function:
|
||||
|
||||
print $in->header ( -cookie => $c );
|
||||
|
||||
=head2 url - Retrieve the current URL.
|
||||
|
||||
Returns the current URL of the script. It defaults to display just the script
|
||||
name and query string.
|
||||
|
||||
Options include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item absolute => 1
|
||||
|
||||
Return the full URL: http://domain/path/to/script.cgi
|
||||
|
||||
=item relative => 1
|
||||
|
||||
Return only the script name: script.cgi
|
||||
|
||||
=item query_string => 1
|
||||
|
||||
Return the query string as well: script.cgi?a=b
|
||||
|
||||
=item path_info => 1
|
||||
|
||||
Returns the path info as well: script.cgi/foobar
|
||||
|
||||
=item remove_empty => 0
|
||||
|
||||
Removes empty query= from the query string.
|
||||
|
||||
=back
|
||||
|
||||
=head2 get_hash - Return all form input as hash.
|
||||
|
||||
This returns the current parameters as a hash. Any values that have the same
|
||||
key will be returned as an array reference of the multiple values.
|
||||
|
||||
=head2 escape - URL escape a string.
|
||||
|
||||
Returns the passed in value URL escaped. Can be called as class method or
|
||||
object method.
|
||||
|
||||
=head2 unescape - URL unescape a string.
|
||||
|
||||
Returns the passed in value URL un-escaped. Can be called as class method or
|
||||
object method. Optionally can take an array reference of strings instead of a
|
||||
string. If called in this method, the values of the array reference will be
|
||||
directly altered.
|
||||
|
||||
=head2 html_escape - HTML escape a string
|
||||
|
||||
Returns the passed in value HTML escaped. Translates &, <, > and " to their
|
||||
html equivalants.
|
||||
|
||||
=head2 html_unescape - HTML unescapes a string
|
||||
|
||||
Returns the passed in value HTML unescaped.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
Note: GT::CGI depends on L<GT::Base> and L<GT::AutoLoader>, and if you are
|
||||
performing file uploads, GT::CGI::MultiPart, GT::CGI::Fh, and L<GT::TempFile>.
|
||||
The ability to set cookies requires GT::CGI::Cookie.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: CGI.pm,v 1.145 2005/06/21 21:02:57 jagerman Exp $
|
||||
|
||||
=cut
|
||||
101
site/glist/lib/GT/CGI/Action.pm
Normal file
101
site/glist/lib/GT/CGI/Action.pm
Normal file
@ -0,0 +1,101 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Action.pm,v 1.8 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# An API to make writting CGIs easier.
|
||||
#
|
||||
|
||||
package GT::CGI::Action;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@ISA @EXPORT/;
|
||||
use strict;
|
||||
|
||||
use GT::CGI::Action::Common;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(GT::CGI::Action::Common);
|
||||
@EXPORT = qw(ACT_ERROR ACT_OK ACT_EXIT);
|
||||
|
||||
sub can_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
|
||||
my $pages = $self->config->{pages};
|
||||
return undef unless defined $pages and exists $pages->{$page};
|
||||
return $pages->{$page}[PAGE_CAN];
|
||||
}
|
||||
|
||||
sub can_action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $action = shift;
|
||||
croak "No action specified" unless defined $action;
|
||||
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
my $actions = $self->config->{actions};
|
||||
return undef unless defined $actions and exists $actions->{$action};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub run_action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $action = shift;
|
||||
croak "No page specified" unless defined $action;
|
||||
|
||||
my $actions = $self->config->{actions};
|
||||
croak "$action does not exist"
|
||||
unless defined $actions and exists $actions->{$action};
|
||||
|
||||
my ($class, $func) = ($actions->{$action}[ACT_FUNCTION] =~ /(.+)::([^:]+)/);
|
||||
eval "use $class();";
|
||||
die "$@\n" if $@;
|
||||
my $this = $class->new(%$self);
|
||||
$this->action($action);
|
||||
$this->$func(@_);
|
||||
return $this;
|
||||
}
|
||||
|
||||
# Shortcut function
|
||||
sub run_returns {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $obj = shift;
|
||||
croak "No object defined" unless defined $obj;
|
||||
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
|
||||
if ($obj->return == ACT_ERROR) {
|
||||
$self->print_page($obj->error_page);
|
||||
}
|
||||
elsif ($obj->return == ACT_OK) {
|
||||
$self->print_page($obj->success_page);
|
||||
}
|
||||
elsif ($obj->return != ACT_EXIT) {
|
||||
die "Unknown return from $obj";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
286
site/glist/lib/GT/CGI/Action/Common.pm
Normal file
286
site/glist/lib/GT/CGI/Action/Common.pm
Normal file
@ -0,0 +1,286 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action::Common
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Common.pm,v 1.14 2004/09/07 23:35:14 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Provides a base class for GT::CGI::Action objects
|
||||
#
|
||||
|
||||
package GT::CGI::Action::Common;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@EXPORT @ISA/;
|
||||
use strict;
|
||||
use constants
|
||||
|
||||
# Index in config action values
|
||||
ACT_FUNCTION => 0,
|
||||
ACT_ERROR_PAGE => 1,
|
||||
ACT_SUCCESS_PAGE => 2,
|
||||
|
||||
# Index in config page values
|
||||
PAGE_CAN => 0,
|
||||
PAGE_FUNCTION => 1,
|
||||
|
||||
# Action returns
|
||||
ACT_ERROR => 0,
|
||||
ACT_OK => 1,
|
||||
ACT_EXIT => 3;
|
||||
|
||||
use Carp;
|
||||
use Exporter();
|
||||
|
||||
@ISA = qw/Exporter/;
|
||||
@EXPORT = qw(
|
||||
ACT_FUNCTION
|
||||
ACT_ERROR_PAGE
|
||||
ACT_SUCCESS_PAGE
|
||||
PAGE_CAN
|
||||
PAGE_FUNCTION
|
||||
ACT_EXIT
|
||||
ACT_OK
|
||||
ACT_ERROR
|
||||
);
|
||||
|
||||
sub new {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
croak "Areguments to new() must be a hash" if @_ & 1;
|
||||
my %opts = @_;
|
||||
|
||||
my $guess_mime = exists($opts{guess_mime}) ? delete($opts{guess_mime}) : 1;
|
||||
|
||||
my $cgi = delete $opts{cgi};
|
||||
unless (defined $cgi) {
|
||||
require GT::CGI;
|
||||
$cgi = new GT::CGI;
|
||||
}
|
||||
|
||||
my $tpl = delete $opts{template};
|
||||
unless (defined $tpl) {
|
||||
require GT::Template;
|
||||
$tpl = new GT::Template;
|
||||
}
|
||||
|
||||
my $debug = delete $opts{debug};
|
||||
|
||||
my $tags = delete $opts{tags};
|
||||
$tags = {} unless defined $tags;
|
||||
|
||||
my $config = delete $opts{config};
|
||||
croak "No config specified"
|
||||
unless defined $config;
|
||||
|
||||
my $action = delete $opts{action};
|
||||
my $heap = delete $opts{heap};
|
||||
|
||||
croak "Unknown arguments: ", sort keys %opts if keys %opts;
|
||||
|
||||
my $self = bless {
|
||||
cgi => $cgi,
|
||||
template => $tpl,
|
||||
tags => $tags,
|
||||
guess_mime => $guess_mime,
|
||||
action => $action,
|
||||
debug => $debug,
|
||||
heap => $heap
|
||||
}, $class;
|
||||
$self->config($config);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub config {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{config} = shift;
|
||||
unless (ref $self->{config}) {
|
||||
require GT::Config;
|
||||
$self->{config} = GT::Config->load($self->{config}, {
|
||||
inheritance => 1,
|
||||
cache => 1,
|
||||
create_ok => 0,
|
||||
strict => 0,
|
||||
debug => $self->{debug},
|
||||
compile_subs => 0,
|
||||
});
|
||||
}
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{config};
|
||||
}
|
||||
|
||||
sub tags {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my %tags;
|
||||
if (ref($_[0]) eq 'HASH') {
|
||||
%tags = %{shift()};
|
||||
}
|
||||
else {
|
||||
croak "Arguments to tags() must be a hash or hash ref" if @_ & 1;
|
||||
%tags = @_;
|
||||
}
|
||||
@{$self->{tags}}{keys %tags} = (values %tags)
|
||||
if keys %tags;
|
||||
return $self->{tags};
|
||||
}
|
||||
|
||||
sub cgi {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{cgi} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{cgi};
|
||||
}
|
||||
|
||||
sub heap {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{heap} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{heap};
|
||||
}
|
||||
|
||||
sub action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{action} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{action};
|
||||
}
|
||||
|
||||
sub guess_mime {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{guess_mime} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{guess_mime};
|
||||
}
|
||||
|
||||
sub debug {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{debug} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{debug};
|
||||
}
|
||||
|
||||
sub template {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{template} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{template};
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(message => "message");
|
||||
sub info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
$self->tags(message => $message);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(message => "message"); $self->print_page("page");
|
||||
sub print_info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
$self->info(@_);
|
||||
$self->print_page($page);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(error => "message");
|
||||
sub error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
$self->tags(error => $error);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(error => "message"); $self->print_page("page");
|
||||
sub print_error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
$self->info(@_);
|
||||
$self->print_page($page);
|
||||
}
|
||||
|
||||
# Shortcut to print $self->cgi->cookie(..)->cookie_header, "\r\n";
|
||||
sub print_cookie {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
print $self->cgi->cookie(@_)->cookie_header, "\r\n";
|
||||
}
|
||||
|
||||
sub print_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified to print" unless defined $page;
|
||||
$self->tags(page => $page);
|
||||
|
||||
if (defined $self->{config}{pages}{$page}[PAGE_FUNCTION]) {
|
||||
my ($class, $func) = ($self->{config}{pages}{$page}[PAGE_FUNCTION] =~ /(.+)::([^:]+)/);
|
||||
eval "use $class();";
|
||||
die "$@\n" if $@;
|
||||
my $this = $class->new(%$self);
|
||||
$this->$func(@_);
|
||||
}
|
||||
|
||||
if ($self->guess_mime) {
|
||||
require GT::MIMETypes;
|
||||
my $type = GT::MIMETypes->guess_type($page);
|
||||
print $self->cgi->header($type);
|
||||
if ($type =~ /text/) {
|
||||
return $self->template->parse_print($page, $self->tags);
|
||||
}
|
||||
else {
|
||||
local *FH;
|
||||
open FH, "<$page"
|
||||
or die "Could not open $page; Reason: $!";
|
||||
my $buff;
|
||||
binmode STDOUT;
|
||||
while (read(FH, $buff, 4096)) {
|
||||
print STDOUT $buff;
|
||||
}
|
||||
close FH;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $self->cgi->header;
|
||||
}
|
||||
$self->template->parse_print($page, $self->tags);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
106
site/glist/lib/GT/CGI/Action/Plugin.pm
Normal file
106
site/glist/lib/GT/CGI/Action/Plugin.pm
Normal file
@ -0,0 +1,106 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action::Plugin
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Plugin.pm,v 1.5 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
#
|
||||
|
||||
package GT::CGI::Action::Plugin;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@ISA @EXPORT/;
|
||||
use strict;
|
||||
|
||||
use GT::CGI::Action::Common;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(GT::CGI::Action::Common);
|
||||
@EXPORT = qw(ACT_ERROR ACT_OK ACT_EXIT);
|
||||
|
||||
sub return {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{return} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{return};
|
||||
}
|
||||
|
||||
sub info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::info(@_) if @_;
|
||||
$self->return(ACT_OK);
|
||||
}
|
||||
|
||||
sub print_info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::print_info(@_);
|
||||
$self->return(ACT_EXIT);
|
||||
}
|
||||
|
||||
sub error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::error(@_) if @_;
|
||||
$self->return(ACT_ERROR);
|
||||
}
|
||||
|
||||
sub print_error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::print_error(@_);
|
||||
$self->return(ACT_ERROR);
|
||||
}
|
||||
|
||||
sub exit {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->return(ACT_EXIT);
|
||||
}
|
||||
|
||||
sub error_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{error_page} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
if (defined $self->{error_page}) {
|
||||
return $self->{error_page};
|
||||
}
|
||||
croak "No action was ever specified" unless defined $self->action;
|
||||
return $self->{config}{actions}{$self->action}[ACT_ERROR_PAGE];
|
||||
|
||||
}
|
||||
|
||||
sub success_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{success_page} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
if (defined $self->{success_page}) {
|
||||
return $self->{success_page};
|
||||
}
|
||||
croak "No action was ever specified" unless defined $self->action;
|
||||
return $self->{config}{actions}{$self->action}[ACT_SUCCESS_PAGE];
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
101
site/glist/lib/GT/CGI/Cookie.pm
Normal file
101
site/glist/lib/GT/CGI/Cookie.pm
Normal file
@ -0,0 +1,101 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Cookie
|
||||
# CVS Info :
|
||||
# $Id: Cookie.pm,v 1.5 2004/08/19 23:49:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Handles cookie creation and formatting
|
||||
#
|
||||
|
||||
package GT::CGI::Cookie;
|
||||
#================================================================================
|
||||
|
||||
use strict;
|
||||
use GT::CGI;
|
||||
use GT::Base;
|
||||
use vars qw/@ISA $ATTRIBS @MON @WDAY/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
|
||||
$ATTRIBS = {
|
||||
-name => '',
|
||||
-value => '',
|
||||
-expires => '',
|
||||
-path => '',
|
||||
-domain => '',
|
||||
-secure => ''
|
||||
};
|
||||
@MON = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
|
||||
@WDAY = qw/Sun Mon Tue Wed Thu Fri Sat/;
|
||||
|
||||
sub cookie_header {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a cookie header.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# make sure we have a name to use
|
||||
$self->{-name} or return;
|
||||
|
||||
my $name = GT::CGI::escape($self->{-name});
|
||||
my $value = GT::CGI::escape($self->{-value});
|
||||
|
||||
# build the header that creates the cookie
|
||||
my $header = "Set-Cookie: $name=$value";
|
||||
|
||||
$self->{-expires} and $header .= "; expires=" . $self->format_date('-', $self->{-expires});
|
||||
$self->{-path} and $header .= "; path=$self->{-path}";
|
||||
$self->{-domain} and $header .= "; domain=$self->{-domain}";
|
||||
$self->{-secure} and $header .= "; secure";
|
||||
|
||||
return "$header";
|
||||
}
|
||||
|
||||
sub format_date {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a string in http_gmt format, but accepts one in unknown format.
|
||||
# Wed, 23 Aug 2000 21:20:14 GMT
|
||||
#
|
||||
my ($self, $sep, $datestr) = @_;
|
||||
my $unix_time = defined $datestr ? $self->expire_calc($datestr) : time;
|
||||
|
||||
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($unix_time);
|
||||
$year += 1900;
|
||||
|
||||
return sprintf(
|
||||
"%s, %02d$sep%s$sep%04d %02d:%02d:%02d GMT",
|
||||
$WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec
|
||||
);
|
||||
}
|
||||
*_format_date = \&format_date; # deprecated
|
||||
|
||||
sub expire_calc {
|
||||
# -------------------------------------------------------------------
|
||||
# Calculates when a date based on +- times. See CGI.pm for more info.
|
||||
#
|
||||
my ($self, $time) = @_;
|
||||
my %mult = (s => 1, m => 60, h => 3600, d => 86400, M => 2592000, y => 31536000);
|
||||
my $offset;
|
||||
|
||||
if (!$time or lc $time eq 'now') {
|
||||
$offset = 0;
|
||||
}
|
||||
elsif ($time =~ /^\d/) {
|
||||
return $time;
|
||||
}
|
||||
elsif ($time=~/^([+-]?(?:\d+(?:\.\d*)?|\.\d+))([smhdMy]?)/) {
|
||||
$offset = $1 * ($mult{$2} || 1);
|
||||
}
|
||||
else {
|
||||
return $time;
|
||||
}
|
||||
return time + $offset;
|
||||
}
|
||||
*_expire_calc = \&expire_calc; # deprecated
|
||||
|
||||
1;
|
||||
502
site/glist/lib/GT/CGI/EventLoop.pm
Normal file
502
site/glist/lib/GT/CGI/EventLoop.pm
Normal file
@ -0,0 +1,502 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::EventLoop
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: EventLoop.pm,v 1.5 2004/09/07 23:35:14 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Impliments an EventLoop API for CGI programming
|
||||
#
|
||||
|
||||
package GT::CGI::EventLoop;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/$ATTRIBS $ERRORS @EXPORT_OK %EXPORT_TAGS/;
|
||||
use strict;
|
||||
use bases 'GT::Base' => ''; # GT::Base inherits from Exporter
|
||||
use constants
|
||||
STOP => 1,
|
||||
EXIT => 2,
|
||||
CONT => 3,
|
||||
HEAP => 0,
|
||||
EVENT => 1,
|
||||
IN => 2,
|
||||
CGI => 3,
|
||||
ARG0 => 4,
|
||||
ARG1 => 5,
|
||||
ARG2 => 6,
|
||||
ARG3 => 7,
|
||||
ARG4 => 8,
|
||||
ARG5 => 9,
|
||||
ARG6 => 10,
|
||||
ARG7 => 11,
|
||||
ARG8 => 12,
|
||||
ARG9 => 13;
|
||||
|
||||
use GT::CGI;
|
||||
use GT::MIMETypes;
|
||||
|
||||
$ERRORS = {
|
||||
NOACTION => 'No action was passed from CGI input and no default action was set',
|
||||
NOFUNC => 'No function in %s'
|
||||
};
|
||||
|
||||
$ATTRIBS = {
|
||||
do => 'do',
|
||||
format_page_tags => undef,
|
||||
default_do => undef,
|
||||
init_events => undef,
|
||||
init_events_name => undef,
|
||||
default_page => 'home',
|
||||
default_group => undef,
|
||||
default_page_pre_event => undef,
|
||||
default_page_post_event => undef,
|
||||
default_group_pre_event => undef,
|
||||
default_group_post_event => undef,
|
||||
needs_array_input => undef,
|
||||
plugin_object => undef,
|
||||
template_path => undef,
|
||||
pre_package => '',
|
||||
cgi => undef,
|
||||
in => {},
|
||||
heap => {},
|
||||
page_events => {},
|
||||
page_pre_events => {},
|
||||
page_post_events => {},
|
||||
group_pre_events => {},
|
||||
group_post_events => {},
|
||||
groups => {},
|
||||
group => undef,
|
||||
page => undef,
|
||||
print_page => \>::CGI::EventLoop::print_page,
|
||||
status => CONT,
|
||||
cookies => []
|
||||
};
|
||||
|
||||
@EXPORT_OK = qw/
|
||||
STOP EXIT CONT
|
||||
HEAP EVENT IN CGI
|
||||
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
||||
/;
|
||||
|
||||
%EXPORT_TAGS = (
|
||||
all => [@EXPORT_OK],
|
||||
status => [qw/STOP EXIT CONT/],
|
||||
args => [qw/
|
||||
HEAP EVENT IN CGI
|
||||
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
||||
/]
|
||||
);
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->set( @_ ) if @_;
|
||||
$self->{cgi} ||= new GT::CGI;
|
||||
for ( $self->{cgi}->param ) {
|
||||
my @val = $self->{cgi}->param($_);
|
||||
my $val;
|
||||
my $match;
|
||||
for my $field ( @{$self->{needs_array_input}} ) {
|
||||
if ( $_ eq $field ) {
|
||||
$match = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ( !$match ) {
|
||||
$val = $val[0];
|
||||
}
|
||||
else {
|
||||
$val = \@val;
|
||||
}
|
||||
$self->{in}{$_} = $val;
|
||||
}
|
||||
}
|
||||
|
||||
sub mainloop {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->init( @_ ) if @_;
|
||||
|
||||
if ( !defined $self->{in}{$self->{do}} ) {
|
||||
if ( defined $self->{default_do} ) {
|
||||
$self->{in}{$self->{do}} = $self->{default_do};
|
||||
}
|
||||
else {
|
||||
$self->fatal( 'NOACTION' );
|
||||
}
|
||||
}
|
||||
if ( $self->{init_events} ) {
|
||||
local $self->{in}{$self->{do}} = $self->{init_events_name} if $self->{init_events_name};
|
||||
|
||||
$self->dispatch( $self->{init_events} );
|
||||
return if $self->{status} == EXIT;
|
||||
}
|
||||
$self->_call_group;
|
||||
$self->_call_page;
|
||||
}
|
||||
|
||||
sub do_param {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ ) {
|
||||
$self->add_hidden( $self->{do} => $_[0] );
|
||||
}
|
||||
return $self->{in}{$self->{do}};
|
||||
}
|
||||
|
||||
sub stop { $_[0]->{status} = STOP }
|
||||
sub exit { $_[0]->{status} = EXIT }
|
||||
sub cont { $_[0]->{status} = CONT }
|
||||
|
||||
sub _call_group {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->{group} ||= $self->{in}{$self->{do}} || $self->{default_do};
|
||||
my $orig_group = $self->{group};
|
||||
# FIXME Add infinite recursion checks!
|
||||
for ( keys %{$self->{groups}} ) {
|
||||
if ( index( $self->{group}, $_ ) == 0 ) {
|
||||
if ( exists $self->{group_pre_events}{$_} ) {
|
||||
$self->dispatch( $self->{group_pre_events}{$_} );
|
||||
return if $self->{status} == EXIT;
|
||||
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_group_pre_event} ) {
|
||||
$self->dispatch( $self->{default_group_pre_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
$self->dispatch( $self->{groups}{$_} );
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
if ( exists $self->{group_post_events}{$_} ) {
|
||||
$self->dispatch( $self->{group_post_events}{$_} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_group_post_event} ) {
|
||||
$self->dispatch( $self->{default_group_post_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Default group
|
||||
$self->dispatch( $self->{default_group} ) if $self->{default_group};
|
||||
if ( $self->{default_group} and $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
|
||||
sub _call_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
if ( !$self->{page} ) {
|
||||
$self->page( $self->{default_page} );
|
||||
}
|
||||
my $orig_page = $self->{page};
|
||||
if ( exists $self->{page_pre_events}{$self->{page}} ) {
|
||||
$self->dispatch( $self->{page_pre_events}{$self->{page}} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{page} ne $orig_page ) {
|
||||
return $self->_call_page;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_page_pre_event} ) {
|
||||
$self->dispatch( $self->{default_page_pre_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{page} ne $orig_page ) {
|
||||
return $self->_call_page;
|
||||
}
|
||||
}
|
||||
$self->{print_page}->( $self );
|
||||
|
||||
# Run post page events, can't change the page on a post event
|
||||
if ( exists $self->{page_post_events}{$self->{page}} ) {
|
||||
$self->dispatch( $self->{page_post_events}{$self->{page}} );
|
||||
}
|
||||
elsif ( defined $self->{default_page_post_event} ) {
|
||||
$self->dispatch( $self->{default_page_post_event} );
|
||||
}
|
||||
}
|
||||
|
||||
sub cookie_jar {
|
||||
# --------------------------------------------------------------------
|
||||
# $obj->cookie_jar($cookie_object);
|
||||
# ---------------------------------
|
||||
# Stores cookies for printing when print_page is called.
|
||||
# $cookie_object should be a GT::CGI::Cookie object. Passing undef
|
||||
# will empty the cookies array ref.
|
||||
#
|
||||
my $self = shift;
|
||||
if ( !defined( $_[0] ) and @_ > 0 ) {
|
||||
$self->{cookies} = [];
|
||||
}
|
||||
elsif ( @_ > 0 ) {
|
||||
push( @{$self->{cookies}}, $_[0] );
|
||||
}
|
||||
return $self->{cookies};
|
||||
}
|
||||
|
||||
sub add_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ and !defined( $_[0] ) ) {
|
||||
$self->{hidden} = {};
|
||||
}
|
||||
elsif ( @_ ) {
|
||||
$self->{hidden}{$_[0]} = $_[1];
|
||||
}
|
||||
}
|
||||
|
||||
sub remove_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return delete $self->{hidden}{$_[0]};
|
||||
}
|
||||
|
||||
sub get_url_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $ret = '';
|
||||
for ( keys %{$self->{hidden}} ) {
|
||||
next unless defined $self->{hidden}{$_};
|
||||
$ret .= $self->{cgi}->escape( $_ ).'='.$self->{cgi}->escape( $self->{hidden}{$_} ).';';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub get_form_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $ret = '';
|
||||
for ( keys %{$self->{hidden}} ) {
|
||||
next unless defined $self->{hidden}{$_};
|
||||
$ret .= '<input type="hidden" name="'.$self->{cgi}->html_escape( $_ ).'" value="'.$self->{cgi}->html_escape( $self->{hidden}{$_} ).'">';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub page {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ > 0 ) {
|
||||
$self->{page} = $self->guess_page( $_[0] );
|
||||
$self->debug( "Set page to $self->{page}" ) if $self->{_debug};
|
||||
$self->yield( $self->{page_events} ) if $self->{page_events};
|
||||
}
|
||||
return $self->{page};
|
||||
}
|
||||
|
||||
sub guess_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $page ) = @_;
|
||||
if ( -e "$self->{template_path}/$page.htm" ) {
|
||||
$page = "$page.htm";
|
||||
}
|
||||
elsif ( -e "$self->{template_path}/$page.html" ) {
|
||||
$page = "$page.html";
|
||||
}
|
||||
return $page;
|
||||
}
|
||||
|
||||
sub tags {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my ( %tags ) = ref( $_[0] ) eq 'HASH' ? %{$_[0]} : @_;
|
||||
for ( keys %tags ) {
|
||||
$self->{tags}{$_} = $tags{$_};
|
||||
}
|
||||
return $self->{tags};
|
||||
}
|
||||
|
||||
sub default_tags {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %tags ) = @_;
|
||||
|
||||
my $set;
|
||||
for ( keys %tags ) {
|
||||
$set->{$_} = ( defined( $self->{in}{$_} ) and length( $self->{in}{$_} ) ? $self->{in}{$_} : $tags{$_} );
|
||||
}
|
||||
$self->tags( %$set );
|
||||
}
|
||||
|
||||
sub print_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $form_hidden = $self->get_form_hidden;
|
||||
my $url_hidden = $self->get_url_hidden;
|
||||
my $tags = $self->tags( url_hidden => \$url_hidden, form_hidden => \$form_hidden );
|
||||
$tags = $self->yield( $self->{format_page_tags}, $tags ) if defined $self->{format_page_tags};
|
||||
my $page = $self->page || 'index.htm';
|
||||
|
||||
# Cookies can be set with CGI input
|
||||
my $cookies = [];
|
||||
if ( $self->{in}{'set-cookie'} ) {
|
||||
foreach my $key ( keys %{$self->{in}} ) {
|
||||
if ( $key =~ /^cookie-(.*)/ ) {
|
||||
push @$cookies, $self->{cgi}->cookie( -name => $1, -value => $self->{in}{$key}, -path => '/' );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# See if we have any cookies in out cookie jar (used through program operation to set cookies without printing
|
||||
# a header)
|
||||
if ( @{$self->cookie_jar} ) {
|
||||
push @$cookies, @{$self->cookie_jar};
|
||||
}
|
||||
|
||||
# If we have cookie header to print print them
|
||||
print @{$cookies}
|
||||
? $self->{cgi}->header(
|
||||
-cookie => $cookies,
|
||||
-type => GT::MIMETypes->guess_type( $page )
|
||||
)
|
||||
: $self->{cgi}->header( GT::MIMETypes->guess_type( $page ) );
|
||||
|
||||
my $base = $self->{template_path};
|
||||
|
||||
# Make sure the template exists and is readable
|
||||
-e "$base/$page" or die "No page ($base/$page)";
|
||||
-r _ or die "Page isn't readable by this process ($< $>) ($base/$page)";
|
||||
|
||||
require GT::Template;
|
||||
GT::Template->parse( $page, $tags, {
|
||||
root => $base,
|
||||
escape => 1,
|
||||
print => 1,
|
||||
heap => [ $self->func_args ]
|
||||
} );
|
||||
|
||||
}
|
||||
|
||||
sub page_pre_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{page_pre_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{page_pre_events}{$self->guess_page( $_ )} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{page_pre_events};
|
||||
}
|
||||
|
||||
sub page_post_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{page_post_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{page_post_events}{$self->guess_page( $_ )} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{page_post_events};
|
||||
}
|
||||
|
||||
sub group_pre_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{group_pre_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{group_pre_events}{$_} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{group_pre_events};
|
||||
}
|
||||
|
||||
sub group_post_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{group_post_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{group_post_events}{$_} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{group_post_events};
|
||||
}
|
||||
|
||||
sub dispatch {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $pfunc, @args ) = @_;
|
||||
$pfunc = ref( $pfunc ) eq 'ARRAY' ? $pfunc : [ $pfunc ];
|
||||
for ( @$pfunc ) {
|
||||
$self->yield( $_, @args );
|
||||
return if $self->{status} == EXIT or $self->{status} == STOP;
|
||||
}
|
||||
}
|
||||
|
||||
sub yield {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $pfunc, @args ) = @_;
|
||||
if ( !ref( $pfunc ) ) {
|
||||
$self->debug( "Yielding $pfunc" ) if $self->{_debug} > 1;
|
||||
my ( $pkg, $func );
|
||||
if ( index( $pfunc, '::' ) != -1 ) {
|
||||
($pkg, $func) = $pfunc =~ /^(.*)::(.*)$/;
|
||||
}
|
||||
else {
|
||||
$func = $pfunc;
|
||||
}
|
||||
defined( $func ) or $self->fatal( 'NOFUNC', $pfunc );
|
||||
$pkg = $self->{pre_package}.$pkg if $self->{pre_package} and $pkg;
|
||||
$pkg ||= $self->{pre_package} if $self->{pre_package};
|
||||
$pkg ||= 'main';
|
||||
$pkg =~ s/::$//;
|
||||
no strict 'refs';
|
||||
unless ( defined %{$pkg . '::'} ) {
|
||||
eval "require $pkg";
|
||||
die "Could not compile $pkg; Reason: $@" if $@;
|
||||
}
|
||||
if ( defined $self->{plugin_object} ) {
|
||||
$self->debug( "dispatching --> $pkg\::$func" ) if $self->{_debug};
|
||||
return $self->{plugin_object}->dispatch( $pkg.'::'.$func, \&{$pkg.'::'.$func}, $self->func_args(@args) );
|
||||
}
|
||||
else {
|
||||
no strict 'refs';
|
||||
$self->debug( "Calling $pkg\::$func" ) if $self->{_debug};
|
||||
return &{$pkg.'::'.$func}( $self->func_args(@args) );
|
||||
}
|
||||
$self->yield( $_, @args );
|
||||
}
|
||||
elsif ( ref( $pfunc ) eq 'CODE' ) {
|
||||
$self->debug( "In yeild with code ref.") if $self->{_debug};
|
||||
if ( defined $self->{plugin_object} ) {
|
||||
$self->debug( "dispatching --> $self->{in}{$self->{do}}" ) if $self->{_debug};
|
||||
return $self->{plugin_object}->dispatch( $self->{in}{$self->{do}}, $pfunc, $self->func_args(@args) );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Calling code ref" ) if $self->{_debug};
|
||||
return $pfunc->( $self->func_args(@args) );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub func_args { $_[0]->{heap}, $_[0], $_[0]->{in}, $_[0]->{cgi}, @_[1 .. $#_] }
|
||||
|
||||
1;
|
||||
|
||||
|
||||
70
site/glist/lib/GT/CGI/Fh.pm
Normal file
70
site/glist/lib/GT/CGI/Fh.pm
Normal file
@ -0,0 +1,70 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Fh
|
||||
# CVS Info :
|
||||
# $Id: Fh.pm,v 1.2 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Magic filehandle that prints the name, but is still a filehandle for reads -
|
||||
# just like CGI.pm.
|
||||
#
|
||||
package GT::CGI::Fh;
|
||||
# ===================================================================
|
||||
use strict 'vars', 'subs';
|
||||
use vars qw/$FH/;
|
||||
use Fcntl qw/O_RDWR O_EXCL/;
|
||||
use overload
|
||||
'""' => \&as_string,
|
||||
'cmp' => \&compare,
|
||||
'fallback' => 1;
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------------------
|
||||
# Create a new filehandle based on a counter, and the filename.
|
||||
#
|
||||
my ($pkg, $name, $file, $delete) = @_;
|
||||
my $fname = sprintf("FH%05d%s", ++$FH, $name);
|
||||
|
||||
$fname =~ s/([:'%])/sprintf '%%%02X', ord $1/eg;
|
||||
my $fh = \do { local *{$fname}; *{$fname} };
|
||||
|
||||
sysopen($fh, $file, O_RDWR | O_EXCL, 0600) or die "Can't open file: $file ($!)";
|
||||
unlink($file) if $delete;
|
||||
bless $fh, $pkg;
|
||||
|
||||
return $fh;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
# -------------------------------------------------------------------
|
||||
# Return the filename, strip off leading junk first.
|
||||
#
|
||||
my $self = shift;
|
||||
my $fn = $$self;
|
||||
$fn =~ s/%(..)/ chr(hex($1)) /eg;
|
||||
$fn =~ s/^\*GT::CGI::Fh::FH\d{5}//;
|
||||
return $fn;
|
||||
}
|
||||
|
||||
sub compare {
|
||||
# -------------------------------------------------------------------
|
||||
# Do comparisions, uses as_string to get file name first.
|
||||
#
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return "$self" cmp $value;
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
# -------------------------------------------------------------------
|
||||
# Close file handle.
|
||||
#
|
||||
my $self = shift;
|
||||
close $self;
|
||||
}
|
||||
|
||||
1;
|
||||
254
site/glist/lib/GT/CGI/MultiPart.pm
Normal file
254
site/glist/lib/GT/CGI/MultiPart.pm
Normal file
@ -0,0 +1,254 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::MultiPart
|
||||
# CVS Info :
|
||||
# $Id: MultiPart.pm,v 1.5 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Multipart form handling for GT::CGI objects.
|
||||
#
|
||||
# This is taken almost entirely from CGI.pm, and is loaded on demand.
|
||||
#
|
||||
|
||||
package GT::CGI::MultiPart;
|
||||
# ==============================================================================
|
||||
use strict 'vars', 'subs';
|
||||
use GT::CGI;
|
||||
use GT::Base;
|
||||
use GT::TempFile();
|
||||
use vars qw/$DEBUG $ERRORS @ISA $ATTRIBS $CRLF/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
use constants
|
||||
BLOCK_SIZE => 4096,
|
||||
MAX_READS => 2000;
|
||||
$CRLF = "\015\012";
|
||||
$ATTRIBS = {
|
||||
fh => undef, # web request on stdin
|
||||
buffer => '', # buffer to hold tmp data
|
||||
length => 0, # length of file to parse
|
||||
boundary => undef, # mime boundary to look for
|
||||
fillunit => BLOCK_SIZE, # amount to read per chunk
|
||||
safety => 0 # safety counter
|
||||
};
|
||||
$ERRORS = {
|
||||
NOBOUNDARY => "Unable to find a MIME boundary in environment. Content-type looks like: %s",
|
||||
CLIENTABORT => "Unable to read data from server. Still have %s bytes to read, but got 0. Data in buffer is: %s",
|
||||
BADMULTIPART => "Invalid multipart message. Nothing left to read, and can't find closing boundary. Data in buffer is: %s"
|
||||
};
|
||||
|
||||
sub parse {
|
||||
# -------------------------------------------------------------------
|
||||
# Parses a multipart form to handle file uploads.
|
||||
#
|
||||
my ($class, $cgi) = @_;
|
||||
|
||||
# We override any fatal handlers as our handlers typically create a CGI object
|
||||
# avoiding a nasty loop.
|
||||
local $SIG{__DIE__} = 'DEFAULT';
|
||||
|
||||
# We only load the multipart parser if we have multipart code.
|
||||
my $parser = $class->new or return;
|
||||
|
||||
my ($header, $name, $value, $filename);
|
||||
until ($parser->eof) {
|
||||
$header = $parser->read_header or return die "BADREQUEST";
|
||||
$header->{'Content-Disposition'} =~ m/ name=(?:"([^"]*)"|((?!")[^;]*))/;
|
||||
$name = $1 || $2;
|
||||
($filename) = $header->{'Content-Disposition'} =~ m/ filename="?([^\";]*)"?/;
|
||||
|
||||
# Not a file, just regular form data.
|
||||
if (! defined $filename or $filename eq '') {
|
||||
$value = $parser->read_body;
|
||||
|
||||
# Netscape 6 does some fun things with line feeds in multipart form data
|
||||
$value =~ s/\r\r/\r/g; # What it does on unix
|
||||
$value =~ s/\r\n/\n/g if $^O eq 'MSWin32';
|
||||
unless ($cgi->{params}->{$name}) {
|
||||
push @{$cgi->{param_order}}, $name;
|
||||
}
|
||||
unshift @{$cgi->{params}->{$name}}, $value;
|
||||
next;
|
||||
}
|
||||
|
||||
# Print out the data to a temp file.
|
||||
local $\;
|
||||
my $tmp_file = new GT::TempFile;
|
||||
require GT::CGI::Fh;
|
||||
my $fh = GT::CGI::Fh->new($filename, $$tmp_file, 0);
|
||||
binmode $fh;
|
||||
my $data;
|
||||
while (defined($data = $parser->read)) {
|
||||
print $fh $data;
|
||||
}
|
||||
seek $fh, 0, 0;
|
||||
unless ($cgi->{params}->{$name}) {
|
||||
push @{$cgi->{param_order}}, $name;
|
||||
}
|
||||
unshift @{$cgi->{params}->{$name}}, $fh;
|
||||
}
|
||||
}
|
||||
|
||||
sub init {
|
||||
# -------------------------------------------------------------------
|
||||
# Initilize our object.
|
||||
#
|
||||
$DEBUG = $GT::CGI::DEBUG;
|
||||
|
||||
my $self = shift;
|
||||
|
||||
# Get the boundary marker.
|
||||
my $boundary;
|
||||
if (defined $ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /boundary=\"?([^\";,]+)\"?/) {
|
||||
$boundary = $1;
|
||||
}
|
||||
else {
|
||||
return $self->error("NOBOUNDARY", "FATAL", $ENV{CONTENT_TYPE});
|
||||
}
|
||||
$self->{boundary} = "--$boundary";
|
||||
|
||||
# Get our filehandle.
|
||||
binmode(STDIN);
|
||||
|
||||
# And if the boundary is > the BLOCK_SIZE, adjust.
|
||||
if (length $boundary > $self->{fillunit}) {
|
||||
$self->{fillunit} = length $boundary;
|
||||
}
|
||||
|
||||
# Set the content-length.
|
||||
$self->{length} = $ENV{CONTENT_LENGTH} || 0;
|
||||
|
||||
# Read the preamble and the topmost (boundary) line plus the CRLF.
|
||||
while ($self->read) { }
|
||||
}
|
||||
|
||||
sub fill_buffer {
|
||||
# -------------------------------------------------------------------
|
||||
# Fill buffer.
|
||||
#
|
||||
my ($self, $bytes) = @_;
|
||||
|
||||
return unless $self->{length};
|
||||
|
||||
my $boundary_length = length $self->{boundary};
|
||||
my $buffer_length = length $self->{buffer};
|
||||
my $bytes_to_read = $bytes - $buffer_length + $boundary_length + 2;
|
||||
$bytes_to_read = $self->{length} if $self->{length} < $bytes_to_read;
|
||||
|
||||
my $bytes_read = read(STDIN, $self->{buffer}, $bytes_to_read, $buffer_length);
|
||||
if (! defined $self->{buffer}) {
|
||||
$self->{buffer} = '';
|
||||
}
|
||||
if ($bytes_read == 0) {
|
||||
if ($self->{safety}++ > MAX_READS) {
|
||||
return $self->error(CLIENTABORT => FATAL => $self->{length}, $self->{buffer});
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{safety} = 0;
|
||||
}
|
||||
|
||||
$self->{length} -= $bytes_read;
|
||||
}
|
||||
|
||||
sub read {
|
||||
# -------------------------------------------------------------------
|
||||
# Read some input.
|
||||
#
|
||||
my $self = shift;
|
||||
my $bytes = $self->{fillunit};
|
||||
|
||||
# Load up self->{buffer} with data.
|
||||
$self->fill_buffer($bytes);
|
||||
|
||||
# find the boundary (if exists).
|
||||
my $start = index($self->{buffer}, $self->{boundary});
|
||||
|
||||
# Make sure the post was formed properly.
|
||||
unless (($start >= 0) or ($self->{length} > 0)) {
|
||||
return $self->error(BADMULTIPART => FATAL => $self->{buffer});
|
||||
}
|
||||
|
||||
if ($start == 0) {
|
||||
# Quit if we found the last boundary at the beginning.
|
||||
if (index($self->{buffer},"$self->{boundary}--") == 0) {
|
||||
$self->{buffer} = '';
|
||||
$self->{length} = 0;
|
||||
return;
|
||||
}
|
||||
# Otherwise remove the boundary (+2 to remove line feeds).
|
||||
substr($self->{buffer}, 0, length ($self->{boundary}) + 2) = '';
|
||||
return;
|
||||
}
|
||||
|
||||
my $bytes_to_return;
|
||||
if ($start > 0) {
|
||||
$bytes_to_return = $start > $bytes ? $bytes : $start;
|
||||
}
|
||||
else {
|
||||
$bytes_to_return = $bytes - length($self->{boundary}) + 1;
|
||||
}
|
||||
|
||||
my $return = substr($self->{buffer}, 0, $bytes_to_return);
|
||||
substr($self->{buffer}, 0, $bytes_to_return) = '';
|
||||
|
||||
return $start > 0 ? substr($return, 0, -2) : $return;
|
||||
}
|
||||
|
||||
sub read_header {
|
||||
# -------------------------------------------------------------------
|
||||
# Reads the header.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($ok, $bad, $end, $safety) = (0, 0);
|
||||
until ($ok or $bad) {
|
||||
$self->fill_buffer($self->{fillunit});
|
||||
|
||||
$ok++ if ($end = index($self->{buffer}, "$CRLF$CRLF")) >= 0;
|
||||
$ok++ if $self->{buffer} eq '';
|
||||
$bad++ if !$ok and $self->{length} <= 0;
|
||||
return if $safety++ >= 10;
|
||||
}
|
||||
|
||||
return if $bad;
|
||||
|
||||
my $header = substr($self->{buffer}, 0, $end + 2);
|
||||
substr($self->{buffer}, 0, $end + 4) = '';
|
||||
|
||||
my %header;
|
||||
my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
|
||||
$header =~ s/$CRLF\s+/ /og;
|
||||
while ($header =~ /($token+):\s+([^$CRLF]*)/go) {
|
||||
my ($field_name,$field_value) = ($1,$2);
|
||||
$field_name =~ s/\b(\w)/\u$1/g;
|
||||
$header{$field_name} = $field_value;
|
||||
}
|
||||
return \%header;
|
||||
}
|
||||
|
||||
sub read_body {
|
||||
# -------------------------------------------------------------------
|
||||
# Reads a body and returns as a single scalar value.
|
||||
#
|
||||
my $self = shift;
|
||||
my $data = '';
|
||||
my $return = '';
|
||||
while (defined($data = $self->read)) {
|
||||
$return .= $data;
|
||||
}
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub eof {
|
||||
# -------------------------------------------------------------------
|
||||
# Return true when we've finished reading.
|
||||
#
|
||||
my $self = shift;
|
||||
return 1 if length $self->{buffer} == 0 and $self->{length} <= 0;
|
||||
}
|
||||
|
||||
1;
|
||||
245
site/glist/lib/GT/Cache.pm
Normal file
245
site/glist/lib/GT/Cache.pm
Normal file
@ -0,0 +1,245 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Cache
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements a tied hash cache that will not grow forever, but expire
|
||||
# old/unused entries. Useful under mod_perl.
|
||||
#
|
||||
|
||||
package GT::Cache;
|
||||
# ===============================================================
|
||||
use vars qw /$DEBUG $VERSION $CACHE_SIZE/;
|
||||
use strict;
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
|
||||
$CACHE_SIZE = 500;
|
||||
|
||||
##
|
||||
# tie %cache, 'GT::Cache', $size, \&function;
|
||||
# ----------------------------
|
||||
# Is called when you tie a hash to this
|
||||
# class. The size should be the size limit
|
||||
# you want on your hash. If not specified
|
||||
# this will default to the CLASS variable
|
||||
# $CACH_SIZE which is initialized to 500
|
||||
##
|
||||
sub TIEHASH {
|
||||
my $this = shift;
|
||||
my $size = shift || $CACHE_SIZE;
|
||||
my $code = shift || sub {undef};
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {
|
||||
cache_size => $size,
|
||||
popularity => [],
|
||||
content => {},
|
||||
indices => {},
|
||||
is_indexed => 0,
|
||||
size => 0,
|
||||
code => $code,
|
||||
}, $class;
|
||||
$#{$self->{popularity}} = $size;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
unless (exists $self->{content}->{$key}) {
|
||||
my $val = $self->{code}->($key);
|
||||
defined $val or return undef;
|
||||
$self->STORE ($key, $val);
|
||||
return $val;
|
||||
}
|
||||
if ($self->{is_indexed}) {
|
||||
my ($pos1, $pos2, $replace);
|
||||
|
||||
$pos1 = $self->{content}->{$key}->[1];
|
||||
$pos2 = $pos1 + (int (rand( ($self->{cache_size} - $pos1) / 2) )) || 1;
|
||||
|
||||
$replace = ${$self->{popularity}}[$pos2];
|
||||
|
||||
${$self->{popularity}}[$pos2] = $key;
|
||||
$self->{content}->{$key}->[1] = $pos2;
|
||||
if (defined $replace) {
|
||||
${$self->{popularity}}[$pos1] = $replace;
|
||||
$self->{content}->{$replace}->[1] = $pos1;
|
||||
}
|
||||
}
|
||||
return $self->{content}->{$key}->[0];
|
||||
}
|
||||
|
||||
##
|
||||
# %cash = (key1 => $field1, key2 => $val2);
|
||||
# -----------------------------------------
|
||||
# $cash{key} = $val;
|
||||
# ------------------
|
||||
# Called when you store something in the hash.
|
||||
# This will check the number of elements in the
|
||||
# hash and delete the oldest one if the limit.
|
||||
# is reached.
|
||||
##
|
||||
sub STORE {
|
||||
my ($self, $key, $value) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
my ($replace, $insid);
|
||||
if ($self->{is_indexed}) {
|
||||
$insid = int (rand($self->{cache_size} / 2)) || 1;
|
||||
if (defined ($replace = ${$self->{popularity}}[$insid])) {
|
||||
delete $self->{content}->{$replace};
|
||||
undef ${$self->{popularity}}[$insid];
|
||||
}
|
||||
${$self->{popularity}}[$insid] = $key;
|
||||
$self->{content}->{$key} = [$value, $insid];
|
||||
}
|
||||
else {
|
||||
${$self->{popularity}}[$self->{size}] = $key;
|
||||
$self->{content}->{$key} = [$value, $self->{size}];
|
||||
if ($self->{size} == $self->{cache_size}) {
|
||||
for (0 .. $#{$self->{popularity}}) {
|
||||
next unless defined $self->{popularity}[$_];
|
||||
$self->{content}{$self->{popularity}[$_]}[1] = $_;
|
||||
}
|
||||
$self->{is_indexed} = 1;
|
||||
}
|
||||
$self->{size}++;
|
||||
}
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
exists $self->{content}->{$key} or return undef;
|
||||
$self->{size}--;
|
||||
my $aref = delete $self->{content}->{$key};
|
||||
undef $self->{popularity}->[$aref->[1]];
|
||||
return $aref->[0];
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my $self = shift;
|
||||
$self->{content} = {};
|
||||
$self->{size} = 0;
|
||||
$self->{popularity} = [];
|
||||
$self->{is_indexed} = 0;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
return exists $self->{content}->{$key} ? 1 : 0;
|
||||
}
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
my $c = keys %{$self->{content}};
|
||||
return scalar each %{$self->{content}};
|
||||
}
|
||||
|
||||
sub NEXTKEY {return scalar each %{shift()->{content}}}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Cache - Tied hash which caches output of functions.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Cache;
|
||||
my %cache;
|
||||
tie %cache, 'GT::Cache', $size, \&function;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Cache implements a simple but quick caching scheme for remembering
|
||||
the results of functions. It also implements a max size to prevent
|
||||
the cache from growing and drops least frequently requested entries
|
||||
first, making it very useful under mod_perl.
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
use GT::Cache;
|
||||
my %cache;
|
||||
tie %cache, 'GT::Cache', 100, \&complex_func;
|
||||
|
||||
while (<>) {
|
||||
print "RESULT: ", $cache{$_}, "\n";
|
||||
}
|
||||
|
||||
sub complex_func {
|
||||
my $input = shift;
|
||||
# .. do complex work.
|
||||
return $output;
|
||||
}
|
||||
|
||||
This will cache the results of complex_func, and only run it when
|
||||
the input is different. It stores a max of 100 entries at a time,
|
||||
with the least frequently requested getting dropped first.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Currently, you can only pass as input to the function a single
|
||||
scalar, and the output must be a single scalar. See the
|
||||
Memoize module in CPAN for a much more robust implementation.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $
|
||||
|
||||
=cut
|
||||
927
site/glist/lib/GT/Config.pm
Normal file
927
site/glist/lib/GT/Config.pm
Normal file
@ -0,0 +1,927 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Config
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# A module for handling loading and caching of configuration files.
|
||||
#
|
||||
|
||||
package GT::Config;
|
||||
# ===============================================================
|
||||
|
||||
use strict;
|
||||
|
||||
use GT::Base qw/PERSIST/; # Due to the nature of the config file's hash-like interface, we can't inherit from GT::Base - it sets things in $self. We do need GT::Base for its in_eval function though.
|
||||
use GT::Template::Inheritance;
|
||||
use GT::AutoLoader;
|
||||
|
||||
use constants
|
||||
DATA => 0,
|
||||
INHERITED => 1,
|
||||
FILES => 2,
|
||||
FILES_MOD => 3,
|
||||
CODE_STR => 4;
|
||||
|
||||
use vars qw(%ATT %ATTRIBS %CACHE %SUB_CACHE $error $ERRORS $VERSION);
|
||||
|
||||
# %ATT stores the default attribute values
|
||||
# %ATTRIBS stores the attributes of each object. Since each object works exactly
|
||||
# like a hash ref of the data it represents, these attributes cannot be stored
|
||||
# in $self.
|
||||
# %CACHE is used to cache any data of objects using the 'cache' option. Each
|
||||
# file in here has an array ref value - the first value is a hash ref of the
|
||||
# data, the second a hash ref of inherited keys, the third an array of the
|
||||
# files inherited from, and the fourth a hash of [size, last modification
|
||||
# time] pairs of those files.
|
||||
# %SUB_CACHE is exactly like %CACHE, except that values starting with 'sub {'
|
||||
# will be compiled into code refs. Each array ref has a fifth value - a hash
|
||||
# reference list that stores the original value of any code refs that have
|
||||
# been compiled. %SUB_CACHE is only used when you use 'compile_subs'. Also,
|
||||
# because different packages can be specified, this stores which package the
|
||||
# code ref was compiled in.
|
||||
# $error stores any error that occurs. If a load error happens, you'll need to
|
||||
# use $error to get the error message (when not using the 'create_ok' option).
|
||||
# $ERRORS stores all the error codes
|
||||
# $VERSION - $Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $ - The version.
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.45 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
%ATT = (
|
||||
inheritance => 0, # If set, looks for .tplinfo files for inheritance.
|
||||
local => 0, # If set, will look for "local" directories containing the file. The file will be saved in a "local" subdirectory of the directory given.
|
||||
cache => 1, # If set, GT::Config will look in the cache for the object; objects are always stored in the cache, so that ->load(cache => 0) can be used to reload a file.
|
||||
create_ok => 0, # If set, you'll get a GT::Config object even if the file doesn't exist. You can then save() it to create the file. If not set, a fatal error occurs if the file cannot be located. Note that if the file exists, but has a syntax error, or cannot be read, a fatal error will occur regardless of this option.
|
||||
empty => 0, # If specified, nothing will be read from disk - can be used to force a new, blank config file
|
||||
chmod => 0666, # The octal permissions to set on the file immediately after saving
|
||||
strict => 0, # If true, a fatal error will occur when attempting to access a key that does not exist.
|
||||
debug => 0, # If true, warnings and debugging will be printing to STDERR
|
||||
tmpfile => undef, # Possible values: 0, undef, 1. 0 = no tempfile, undef = tempfile if dir writable, 1 = always tempfile
|
||||
header => '', # Can be set to anything. When saving, this will go before the data. Keep in mind, this has to be correct Perl. [localtime] in here will be replaced with scalar localtime() when saving.
|
||||
compile_subs => '', # Must be set to a package. If set, any value that starts with 'sub {' will be compiled into a code ref, in the package specified.
|
||||
sort_order => undef, # Passed to GT::Dumper->dump as 'order' value if set
|
||||
tab => "\t", # What to use for a "tab" in the config file. Defaults to an actual tab.
|
||||
);
|
||||
|
||||
# Other attributes used internally:
|
||||
# filename => '', # Whatever you give as the filename
|
||||
# file => '', # Just the filename (no path)
|
||||
# path => '', # The path of the filename
|
||||
# files => {}, # A hash of filename => last_mod_time (may contain multiple entries to support inheritance).
|
||||
# file_order => [], # The order of the files in 'files'
|
||||
# data => {}, # The actual data of the config file.
|
||||
# inherited => {}, # Each base key inherited will have $key => 1 in here. Inherited keys are not saved, unless they are changed between load time and save time.
|
||||
# compiled => {}, # Any keys that start with 'sub {' will be compiled into code refs if the compile_subs option is on. The code reference is saved here so that recompiling is not necessary
|
||||
|
||||
$ERRORS = {
|
||||
CANT_LOAD => q _Unable to load '%s': %s._,
|
||||
CANT_COMPILE => q _Unable to compile '%s': %s._,
|
||||
CANT_FIND => q _Config file '%s' does not exist in directory '%s' or has incorrect permissions set._,
|
||||
CANT_WRITE => q _Unable to open '%s' for writing: %s._,
|
||||
CANT_PRINT => q _Unable to write to file '%s': %s._,
|
||||
CANT_RENAME => q _Unable to move '%s' to '%s': %s._,
|
||||
WRITE_MISMATCH => q _Unable to save '%s': wrote %d bytes, but file is %d bytes_,
|
||||
CANT_CREATE_DIR => q _Unable to create directory '%s': %s._,
|
||||
NOT_HASH => q _Config file '%s' did not return a hash reference._,
|
||||
BAD_ARGS => q _Bad arguments. Usage: %s_,
|
||||
NOT_FILE => q _'%s' does not look like a valid filename_,
|
||||
RECURSION => q _Recursive inheritance detected and interrupted: '%s'_,
|
||||
UNKNOWN_OPT => q _Unknown option '%s' passed to %s_,
|
||||
BAD_KEY => q _The key you attempted to access, '%s', does not exist in '%s'_,
|
||||
CANT_COMPILE_CODE => q _Unable to compile '%s' in file '%s': %s_
|
||||
};
|
||||
|
||||
sub load {
|
||||
my $class = shift;
|
||||
|
||||
my (%attribs, %data);
|
||||
|
||||
tie %data, $class, \%attribs;
|
||||
my $self = bless \%data, ref $class || $class;
|
||||
|
||||
$ATTRIBS{$self} = \%attribs; # hehehe ;-)
|
||||
|
||||
my $filename = shift or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
||||
$attribs{filename} = $filename;
|
||||
$attribs{filename_given} = $filename;
|
||||
|
||||
@attribs{'path', 'file'} = ($filename =~ m|^(.*?)[\\/]?([^\\/]+)$|) or return $self->error(NOT_FILE => FATAL => $filename);
|
||||
$attribs{path} = '.' unless length $attribs{path};
|
||||
$filename = $attribs{filename} = "$attribs{path}/$attribs{file}"; # _load_data/_load_tree depend on it being like this.
|
||||
|
||||
my $opts = shift || {};
|
||||
ref $opts eq 'HASH' or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
||||
|
||||
for (keys %ATT) {
|
||||
if (/^(?:inheritance|local|cache|create_ok|strict|empty)$/) {
|
||||
$attribs{$_} = exists $opts->{$_} ? (delete $opts->{$_} ? 1 : 0) : $ATT{$_};
|
||||
}
|
||||
elsif ($_ eq 'tmpfile') {
|
||||
if (exists $opts->{$_}) {
|
||||
my $tmpfile = delete $opts->{$_};
|
||||
$attribs{$_} = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
||||
}
|
||||
else {
|
||||
$attribs{$_} = $ATT{$_};
|
||||
}
|
||||
}
|
||||
else {
|
||||
$attribs{$_} = exists $opts->{$_} ? delete $opts->{$_} : $ATT{$_};
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("Received '$filename' for the file to load", 2) if $attribs{debug} >= 2;
|
||||
|
||||
if (keys %$opts) {
|
||||
$self->error(UNKNOWN_OPT => FATAL => keys %$opts => ref($self) . '->load');
|
||||
}
|
||||
|
||||
$self->debug("Loading '$filename' with options: inheritance => '$attribs{inheritance}', local => '$attribs{local}', cache => '$attribs{cache}', create_ok => '$attribs{create_ok}', empty => '$attribs{empty}', chmod => '$attribs{chmod}', strict => '$attribs{strict}', debug => '$attribs{debug}', compile_subs => '$attribs{compile_subs}'") if $attribs{debug};
|
||||
$self->debug("Header: '$attribs{header}'", 2) if $attribs{debug} >= 2;
|
||||
|
||||
if ($attribs{empty}) {
|
||||
# An empty config file doesn't get added to the cache
|
||||
$self->debug("Not loading any data or cache - 'empty' specified") if $attribs{debug};
|
||||
}
|
||||
elsif ($attribs{cache} and $attribs{compile_subs} and $SUB_CACHE{$attribs{compile_subs}}->{$filename} and my $debug_unchanged = $self->_is_unchanged(@{$SUB_CACHE{$attribs{compile_subs}}->{$filename}}[FILES, FILES_MOD])) {
|
||||
$self->debug("Loading '$filename' from compiled sub cache") if $attribs{debug};
|
||||
@attribs{qw{data inherited file_order files compiled}} = @{$SUB_CACHE{$attribs{compile_subs}}->{$filename}};
|
||||
$attribs{cache_hit} = 1;
|
||||
}
|
||||
elsif ($attribs{cache} and not $attribs{compile_subs} and $CACHE{$filename} and $debug_unchanged = $self->_is_unchanged(@{$CACHE{$filename}}[FILES, FILES_MOD])) {
|
||||
$self->debug("Loading '$filename' from regular cache") if $attribs{debug};
|
||||
@attribs{qw{data inherited file_order files}} = @{$CACHE{$filename}};
|
||||
$attribs{cache_hit} = 1;
|
||||
}
|
||||
else {
|
||||
$self->debug("Not loading '$filename' from cache") if $attribs{debug};
|
||||
if ($attribs{debug} > 1) { # If the debug level is > 1, display some debugging as to _why_ we aren't loading from cache
|
||||
$self->debug("Reason: Caching disabled") if not $attribs{cache};
|
||||
if ($attribs{compile_subs} and not $SUB_CACHE{$attribs{compile_subs}}->{$filename}) { $self->debug("Reason: Not in compiled sub cache") }
|
||||
elsif (not $attribs{compile_subs} and not $CACHE{$filename}) { $self->debug("Reason: Not in regular cache") }
|
||||
$self->debug("Reason: File (or inherited files) have changed") if ($attribs{compile_subs} ? $SUB_CACHE{$attribs{compile_subs}}->{$filename} : $CACHE{$filename}) and not $debug_unchanged;
|
||||
}
|
||||
$self->_load_data($filename) or return;
|
||||
if (@{$attribs{file_order}}) { # Don't cache it if it is a new object
|
||||
if ($attribs{compile_subs}) {
|
||||
$self->debug("Adding '$filename' (compile package '$attribs{compile_subs}') to the compiled sub cache") if $attribs{debug};
|
||||
$SUB_CACHE{$attribs{compile_subs}}->{$filename} = [@attribs{qw{data inherited file_order files compiled}}];
|
||||
}
|
||||
else {
|
||||
$self->debug("Adding '$filename' to the regular cache") if $attribs{debug};
|
||||
$CACHE{$filename} = [@attribs{qw{data inherited file_order files}}];
|
||||
}
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{save} = __LINE__ . <<'END_OF_SUB';
|
||||
sub save {
|
||||
require GT::Dumper;
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my ($d, $i) = @$att{'data', 'inherited'};
|
||||
|
||||
my %data;
|
||||
for (keys %$d) { # Strip out all inherited data
|
||||
next if $i->{$_};
|
||||
|
||||
$data{$_} = $d->{$_};
|
||||
}
|
||||
|
||||
my $filename = $att->{path};
|
||||
|
||||
local $!;
|
||||
if ($att->{local}) {
|
||||
$filename .= "/local";
|
||||
if (!-d $filename) { # $filename is misleading - it's currently a path
|
||||
# Attempt to create the "local" directory
|
||||
mkdir($filename, 0777) or return $self->error(CANT_CREATE_DIR => FATAL => $filename => "$!");
|
||||
CORE::chmod(0777, $filename);
|
||||
}
|
||||
}
|
||||
|
||||
my $tmpfile = $att->{tmpfile};
|
||||
if (not defined $tmpfile) {
|
||||
# Base whether or not we use the tempfile on whether or not we can
|
||||
# write to the base directory of the file:
|
||||
$tmpfile = -w $filename;
|
||||
}
|
||||
|
||||
$filename .= "/$att->{file}";
|
||||
|
||||
$self->debug("Saving '$filename'") if $att->{debug};
|
||||
|
||||
my $localtime = scalar localtime;
|
||||
my $header = $att->{header};
|
||||
if ($header) {
|
||||
$header =~ s/\[localtime\]/$localtime/g;
|
||||
$header .= "\n" unless $header =~ /\n$/;
|
||||
}
|
||||
|
||||
my $write_filename = $tmpfile ? "$filename.tmp.$$." . time . "." . int rand 10000 : $filename;
|
||||
my $printed = 0;
|
||||
my $windows = $^O eq 'MSWin32';
|
||||
|
||||
local *FILE;
|
||||
open FILE, "> $write_filename" or return $self->error(CANT_WRITE => FATAL => $write_filename => "$!");
|
||||
# Print header, if any:
|
||||
if ($header) {
|
||||
$printed += length $header;
|
||||
$printed += $header =~ y/\n// if $windows; # Windows does \n => \r\n translation on FH output
|
||||
unless (print FILE $header) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
}
|
||||
# Print actual data:
|
||||
my $dump = GT::Dumper->dump(
|
||||
var => '',
|
||||
data => \%data,
|
||||
sort => 1,
|
||||
$att->{sort_order} ? (order => $att->{sort_order}) : (),
|
||||
tab => $att->{tab}
|
||||
);
|
||||
$printed += length $dump;
|
||||
$printed += $dump =~ y/\n// if $windows;
|
||||
unless (print FILE $dump) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
# Print the vim info line at the bottom:
|
||||
my $viminfo = "\n# vim:syn=perl:ts=4:noet\n";
|
||||
$printed += length $viminfo;
|
||||
$printed += $viminfo =~ y/\n// if $windows;
|
||||
unless (print FILE $viminfo) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
|
||||
close FILE;
|
||||
|
||||
# Check that the file is the right size, because print() returns true if a
|
||||
# _partial_ print succeeded. Ideally we would check -s on the filehandle after
|
||||
# each print, but of course that doesn't work on Windows.
|
||||
unless ((my $actual = -s $write_filename) == $printed) {
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(WRITE_MISMATCH => FATAL => $write_filename => $printed => $actual);
|
||||
}
|
||||
|
||||
if ($tmpfile) {
|
||||
$self->debug("'$write_filename' saved; renaming to '$filename'") if $att->{debug} > 1;
|
||||
unless (rename $write_filename, $filename) {
|
||||
my $err = "$!";
|
||||
unlink $write_filename;
|
||||
return $self->error(CANT_RENAME => FATAL => $write_filename => $filename => $err);
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $att->{chmod}) {
|
||||
my $mode = (stat $filename)[2] & 07777;
|
||||
CORE::chmod($att->{chmod}, $filename) unless $att->{chmod} == $mode;
|
||||
}
|
||||
$self->debug("'$filename' saved, $printed bytes.") if $att->{debug};
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Returns true if the current object was loaded from cache, false otherwise.
|
||||
sub cache_hit { $ATTRIBS{$_[0]}->{cache_hit} }
|
||||
|
||||
sub _is_unchanged {
|
||||
my ($self, $old_order, $old_mod) = @_;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$self->debug("Checking for any changes in the file (or inherited files)") if $att->{debug};
|
||||
|
||||
my @old_order = @$old_order; # Copy the old file_order and file modification
|
||||
my %old_mod = %$old_mod; # times. _load_tree will replace them.
|
||||
|
||||
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
||||
|
||||
$self->_load_tree($just_do_ok);
|
||||
|
||||
if (@{$att->{file_order}} != @old_order) {
|
||||
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
||||
return;
|
||||
}
|
||||
for (0 .. $#old_order) {
|
||||
if ($old_order[$_] ne $att->{file_order}->[$_]) {
|
||||
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
||||
return; # The inherited files are not the same as before
|
||||
}
|
||||
elsif ($att->{debug} >= 2) {
|
||||
$self->debug("Old order and new order do not differ. Old: (@old_order) New: (@{$att->{file_order}})");
|
||||
}
|
||||
|
||||
if ($old_mod{$old_order[$_]}->[0] != $att->{files}->{$old_order[$_]}->[0]) {
|
||||
$self->debug("The file size of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[0], New: $att->{files}->{$old_order[$_]}->[0]") if $att->{debug};
|
||||
return; # The inherited files have changed in size
|
||||
}
|
||||
elsif ($old_mod{$old_order[$_]}->[1] != $att->{files}->{$old_order[$_]}->[1]) {
|
||||
$self->debug("The modification time of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[1], New: $att->{files}->{$old_order[$_]}->[1]") if $att->{debug};
|
||||
return; # The inherited files have a changed mtime
|
||||
}
|
||||
elsif ($att->{debug} >= 2) {
|
||||
$self->debug("The file size and modification time of $old_order[$_] has not changed");
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("No changes have been made") if $att->{debug};
|
||||
1; # Here's the prize. Nothing is changed.
|
||||
}
|
||||
|
||||
sub _load_data {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
||||
|
||||
$self->_load_tree($just_do_ok) or return;
|
||||
|
||||
if ($just_do_ok and not @{$att->{file_order}}) {
|
||||
push @{$att->{file_order}}, $att->{filename_given};
|
||||
}
|
||||
|
||||
for my $file (@{$att->{file_order}}) {
|
||||
local ($@, $!, $^W);
|
||||
$self->debug("do()ing '$file'") if $att->{debug} >= 2;
|
||||
my $data = do $file;
|
||||
if (!$data and $@) {
|
||||
return $self->error(CANT_LOAD => FATAL => $file => "$@");
|
||||
}
|
||||
elsif (!$data and $!) {
|
||||
return $self->error(CANT_COMPILE => FATAL => $file => "$!");
|
||||
}
|
||||
elsif (ref $data ne 'HASH') {
|
||||
return $self->error(NOT_HASH => FATAL => $file);
|
||||
}
|
||||
if ($just_do_ok or $file eq ($att->{local} ? "$att->{path}/local/$att->{file}" : $att->{filename})) {
|
||||
$att->{data} = $data;
|
||||
}
|
||||
else {
|
||||
for (keys %$data) {
|
||||
next if exists $att->{data}->{$_};
|
||||
$att->{data}->{$_} = $data->{$_};
|
||||
$att->{inherited}->{$_} = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1; # Returning true means loading was successful.
|
||||
}
|
||||
|
||||
sub _load_tree {
|
||||
my $self = shift;
|
||||
my $just_do_ok = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my $root = $att->{path};
|
||||
my $file = $att->{file};
|
||||
|
||||
if ($att->{inheritance}) {
|
||||
$att->{file_order} = [GT::Template::Inheritance->get_all_paths(file => $att->{file}, path => $att->{path})];
|
||||
|
||||
unless (@{$att->{file_order}} or $att->{create_ok} or $just_do_ok) {
|
||||
return $self->error('CANT_FIND' => 'FATAL', $att->{file}, $att->{path});
|
||||
# No files found!
|
||||
}
|
||||
|
||||
for (@{$att->{file_order}}) {
|
||||
$att->{files}->{$_} = [(stat($_))[7, 9]];
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (-e "$root/$file") {
|
||||
$att->{file_order} = ["$root/$file"];
|
||||
$att->{files}->{"$root/$file"} = [(stat("$root/$file"))[7, 9]];
|
||||
}
|
||||
elsif ($att->{create_ok} or $just_do_ok) {
|
||||
$att->{file_order} = [];
|
||||
}
|
||||
else {
|
||||
return $self->error(CANT_FIND => FATAL => $att->{file}, $att->{path});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
$COMPILE{inheritance} = __LINE__ . <<'END_OF_SUB';
|
||||
sub inheritance {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{inheritance};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{tmpfile} = __LINE__ . <<'END_OF_SUB';
|
||||
sub tmpfile {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{tmpfile};
|
||||
my $tmpfile = shift;
|
||||
$tmpfile = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
||||
$att->{tmpfile} = $tmpfile;
|
||||
return $ret;
|
||||
}
|
||||
$att->{tmpfile};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Must be specified in load() - this only retrieves the value
|
||||
$COMPILE{create_ok} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_ok {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{create_ok};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{chmod} = __LINE__ . <<'END_OF_SUB';
|
||||
sub chmod {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{chmod};
|
||||
$att->{chmod} = shift;
|
||||
return $ret;
|
||||
}
|
||||
$att->{chmod};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Must be specified in load()
|
||||
$COMPILE{cache} = __LINE__ . <<'END_OF_SUB';
|
||||
sub cache {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{cache};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{strict} = __LINE__ . <<'END_OF_SUB';
|
||||
sub strict {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{strict} ? 1 : 0;
|
||||
$att->{strict} = shift() ? 1 : 0;
|
||||
return $ret;
|
||||
}
|
||||
$att->{strict};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{debug_level} = __LINE__ . <<'END_OF_SUB';
|
||||
sub debug_level {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{debug};
|
||||
$att->{debug} = shift;
|
||||
return $ret;
|
||||
}
|
||||
$att->{debug};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_SUB';
|
||||
sub debug {
|
||||
# -------------------------------------------------------
|
||||
# Displays a debugging message.
|
||||
#
|
||||
my ($self, $msg, $min) = @_;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
$min ||= 1;
|
||||
return if $att->{debug} < $min;
|
||||
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
# Add line numbers if no \n on the debug message
|
||||
if (substr($msg, -1) ne "\n") {
|
||||
my ($file, $line) = (caller)[1,2];
|
||||
$msg .= " at $file line $line.\n";
|
||||
}
|
||||
|
||||
# Remove windows linefeeds (breaks unix terminals).
|
||||
$msg =~ s/\r//g unless $^O eq 'MSWin32';
|
||||
|
||||
print STDERR "$pkg ($$): $msg";
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{header} = __LINE__ . <<'END_OF_SUB';
|
||||
sub header {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{header};
|
||||
$att->{header} = shift || '';
|
||||
return $ret;
|
||||
}
|
||||
$att->{header};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Be sure to delete the object from %ATTRIBS.
|
||||
sub DESTROY {
|
||||
delete $ATTRIBS{$_[0]} if keys %ATTRIBS and exists $ATTRIBS{$_[0]};
|
||||
}
|
||||
|
||||
$COMPILE{error} = __LINE__ . <<'END_OF_SUB';
|
||||
sub error {
|
||||
my ($self, $code, $type, @args) = @_;
|
||||
$type = $type && uc $type eq 'WARN' ? 'WARN' : 'FATAL';
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
$error = _format_err($pkg, $code, @args);
|
||||
|
||||
if ($type eq 'FATAL') {
|
||||
die $error if GT::Base::in_eval();
|
||||
|
||||
if ($SIG{__DIE__}) {
|
||||
die $error;
|
||||
}
|
||||
else {
|
||||
print STDERR $error;
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
elsif ($ATTRIBS{$self}->{debug}) { # A warning, and debugging is on
|
||||
if ($SIG{__WARN__}) {
|
||||
CORE::warn $error;
|
||||
}
|
||||
else {
|
||||
print STDERR $error;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _format_err {
|
||||
# -------------------------------------------------------
|
||||
# Formats an error message for output.
|
||||
#
|
||||
my ($pkg, $code, @args) = @_;
|
||||
my $msg = sprintf($ERRORS->{$code} || $code, @args);
|
||||
|
||||
my ($file, $line) = GT::Base::get_file_line($pkg);
|
||||
return "$pkg ($$): $msg at $file line $line.\n";
|
||||
}
|
||||
|
||||
# Tied hash handling
|
||||
sub TIEHASH { bless $_[1], $_[0] }
|
||||
sub STORE {
|
||||
$_[0]->{data}->{$_[1]} = $_[2];
|
||||
delete $_[0]->{inherited}->{$_[1]};
|
||||
delete $_[0]->{compiled}->{$_[1]};
|
||||
}
|
||||
sub FETCH {
|
||||
my $att = shift; # $_[0] is NOT $self - it is the attribute hashref
|
||||
my $key = shift;
|
||||
|
||||
if ($att->{strict} and not exists $att->{data}->{$key}) {
|
||||
return GT::Config->error(BAD_KEY => FATAL => $key, $att->{filename});
|
||||
}
|
||||
elsif ($att->{compile_subs} and not ref $att->{data}->{$key} and substr($att->{data}->{$key}, 0, 5) eq 'sub {') {
|
||||
return $att->{compiled}->{$key} if exists $att->{compiled}->{$key};
|
||||
|
||||
my ($code, $err);
|
||||
# Perl breaks when the eval below contains a 'use' statement. Somehow, Perl
|
||||
# thinks it's deeper (in terms of { ... }) than it really is, and so ends up
|
||||
# either exiting the subroutine prematurely, or, if we try to work around that
|
||||
# by using another subroutine, or returning early, by jumping back one
|
||||
# subroutine too many with its return value. So, to get around the whole
|
||||
# problem, we wrap the code in double-evals if it contains 'use' or 'BEGIN'.
|
||||
# It won't _break_ anything, but unfortunately it does slow compiled_subs
|
||||
# globals a little bit slower.
|
||||
if ($att->{data}->{$key} =~ /\b(use|no)\s+[\w:]/ or $att->{data}->{$key} =~ /\bBEGIN\b/) {
|
||||
$code = eval "package $att->{compile_subs}; my \$ret = eval qq|\Q$att->{data}->{$key}\E|; die qq|\$\@\n| if \$\@; \$ret;";
|
||||
}
|
||||
else {
|
||||
$code = eval "package $att->{compile_subs}; $att->{data}->{$key};";
|
||||
}
|
||||
$err = "$@";
|
||||
|
||||
# Perl prior to 5.6.1 breaks on this:
|
||||
# perl -e 'my $c = eval "package SomePkg; sub bar { use NotThere }"; eval "package OtherPkg; print 1"; die "$@" if $@'
|
||||
# From that, we die with: syntax error at (eval 2) line 1, near "package OtherPkg"
|
||||
# This little hack fixes it, but don't ask me why:
|
||||
eval "package Hack;" if $] < 5.006001;
|
||||
|
||||
if (ref $code ne 'CODE') {
|
||||
GT::Config->error(CANT_COMPILE_CODE => WARN => $key, $att->{filename}, $err);
|
||||
my $error = "Unable to compile '$key': $err";
|
||||
$code = sub { $error };
|
||||
}
|
||||
|
||||
return $att->{compiled}->{$key} = $code;
|
||||
}
|
||||
|
||||
$att->{data}->{$key};
|
||||
}
|
||||
|
||||
sub FIRSTKEY { keys %{$_[0]->{data}}; each %{$_[0]->{data}} }
|
||||
sub NEXTKEY { each %{$_[0]->{data}} }
|
||||
sub EXISTS { exists $_[0]->{data}->{$_[1]} }
|
||||
sub DELETE {
|
||||
my $val;
|
||||
$val = $_[0]->FETCH($_[1]) if defined wantarray;
|
||||
delete $_[0]->{inherited}->{$_[1]};
|
||||
delete $_[0]->{data}->{$_[1]};
|
||||
delete $_[0]->{compiled}->{$_[1]};
|
||||
$val;
|
||||
}
|
||||
sub CLEAR { %{$_[0]->{data}} = %{$_[0]->{inherited}} = %{$_[0]->{compiled}} = () }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Config - Dumped-hash configuration handler
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Config;
|
||||
my $Config = GT::Config->load($config_file);
|
||||
...
|
||||
print $Config->{variable};
|
||||
...
|
||||
$Config->{othervar} = "something";
|
||||
...
|
||||
$Config->save;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Config provides a simple way to handle loading config files. It can load
|
||||
and save any config file consisting of a dumped hash. You can then use the
|
||||
object as if it were the actual hash reference from the config file. It
|
||||
supports template set inheritance (see L<GT::Template>) and mtime-based
|
||||
caching.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 load
|
||||
|
||||
There is no C<new()> method. To get a new config object you do:
|
||||
|
||||
$Config = GT::Config->load("/path/to/config/file", { options });
|
||||
|
||||
The first argument is the full path to the file to open to read the
|
||||
configuration. The file does not necessarily have to exist - see the options
|
||||
below.
|
||||
|
||||
The second argument is a hash reference of options, and is optional. The
|
||||
possible options are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item inheritance
|
||||
|
||||
If provided as something true, GT::Config will scan for .tplinfo files looking
|
||||
for inherited template sets. This is typically used for loading globals.txt or
|
||||
language.txt files from Gossamer Threads products' template sets.
|
||||
|
||||
Defaults to off.
|
||||
|
||||
=item local
|
||||
|
||||
If provided as something true, GT::Config will look for a "local" directory
|
||||
containing the file. When using inheritance, a "local" directory will also be
|
||||
looked for in each inherited configuration file. However, regardless of the
|
||||
C<inheritance> option, "local" configuration files always inherit from their
|
||||
non-local counterpart.
|
||||
|
||||
Additionally, this option causes GT::Config to save the file into a "local"
|
||||
directory. Also note that the "local" file will _only_ contain keys that were
|
||||
already in the local file, or were assigned to the config object after loading
|
||||
the file.
|
||||
|
||||
Defaults to off.
|
||||
|
||||
=item cache
|
||||
|
||||
If provided, will look in the internal cache for a cached copy of the file. If
|
||||
none is found, a new GT::Config object will be constructed as usual, then saved
|
||||
in the cache.
|
||||
|
||||
Defaults to on. You must pass C<cache =E<gt> 0> to disable cached loading.
|
||||
Note that new objects are always stored in the cache, allowing you to specify
|
||||
C<cache =E<gt> 0> to force a reload of a cached file.
|
||||
|
||||
=item create_ok
|
||||
|
||||
If set, you'll still get back a GT::Config hash even if the file doesn't exist.
|
||||
You can then save() the object to create a new config file. If this option is
|
||||
not set, a fatal error will occur when attempting to load a file that does not
|
||||
exist.
|
||||
|
||||
Defaults to off. Pass in C<create_ok =E<gt> 1> if the config file doesn't
|
||||
necessarily have to exist (i.e. when creating a new config file).
|
||||
|
||||
=item empty
|
||||
|
||||
The C<empty> option is used to create a new, blank config file - it can be
|
||||
thought of as a forced version of the C<create_ok> option. It won't read
|
||||
B<any> files during loading (and as such completely ignores the C<inheritance>
|
||||
and C<cache> options). This is mainly intended to be used when a complete
|
||||
replacement of a file is desired, regardless of what is currently on disk.
|
||||
|
||||
=item chmod
|
||||
|
||||
The C<chmod> option is used to specify the mode of the saved file. It must be
|
||||
passed in octal form, such as 0644 (but B<not> in string form, such as
|
||||
C<"0644">). The default is 0666, to allow writing by any users. Though not
|
||||
terribly secure, this is the sort of environment most CGI scripts require.
|
||||
Setting a chmod value of undef instructs GT::Config to not perform a chmod.
|
||||
|
||||
=item strict
|
||||
|
||||
If set, a fatal error will occur when attempting to access a key of the config
|
||||
file that does not exist. Note, however, that this only covers the first level
|
||||
data structions - C<$CFG-E<gt>{foo}-E<gt>{bar}> will not fatal if C<foo> is a
|
||||
hash ref, but C<bar> is not set in that hash reference. C<$CFG-E<gt>{foo}>
|
||||
(and C<$CFG-E<gt>{foo}-E<gt>{bar}>) will fatal if the key C<foo> does not exist
|
||||
in the config data.
|
||||
|
||||
=item debug
|
||||
|
||||
If provided, debugging information will be printed. This will also cause a
|
||||
warning to occur if L<"fatal"> is disabled and load fails.
|
||||
|
||||
Defaults to disabled. Should not be used in production code, except when
|
||||
debugging.
|
||||
|
||||
=item tmpfile
|
||||
|
||||
Instructs GT::Config to attempt to use a temporary file when saving. If used,
|
||||
the contents will be written to a temporary file, then, if successfully
|
||||
written, the temporary file will be moved to overwrite the real file. This
|
||||
solves a couple of problems. Firstly, a full disk will never result in a
|
||||
partial file as if the entire file is not written to the temporary file, it
|
||||
will not overwrite the file already stored on disk. Secondly, it avoids a
|
||||
potential problem with multiple processes attempting to write to the file at
|
||||
the same time.
|
||||
|
||||
The following values are accepted:
|
||||
|
||||
0 - Do not use a temporary file
|
||||
undef - Use a temporary file if the base directory is writable
|
||||
1 - Always use a temporary file
|
||||
|
||||
The default is C<undef>, which will attempt to use a temporary file is
|
||||
possible, but won't fail if the script has permission to modify existing files,
|
||||
but not to create new ones.
|
||||
|
||||
=item header
|
||||
|
||||
If provided, when saving a file this header will be written above the data.
|
||||
Keep in mind that the file must be Perl-compilable, so be careful if you are
|
||||
doing anything more than comments.
|
||||
|
||||
Note that the header may contain the string C<[localtime]>, which will be
|
||||
replaced with the return value of C<scalar localtime()> when saving, which is
|
||||
generally a value such as: C<Sun Jan 25 15:12:26 2004>.
|
||||
|
||||
=item tab
|
||||
|
||||
If provided, this will set what to use for tabs when calling save(). Defaults
|
||||
to an actual tab, since that cuts down the file size over using multiple
|
||||
spaces, while leaving the file readable.
|
||||
|
||||
=item compile_subs
|
||||
|
||||
If provided, any data starting with C<sub {> will be compiled into a
|
||||
subroutine. This compilation does not happen until the variable is accessed,
|
||||
at which point a fatal error will occur if the code could not be compiled. The
|
||||
code referenced will be cached (if using caching), but will be saved as the
|
||||
original string (starting with C<sub {>) when L<saving|"save">.
|
||||
|
||||
B<NOTE:> The argument to compile_subs must be a valid perl package; the code
|
||||
reference will be compiled in that package. For example,
|
||||
C<compile_subs =E<gt> 'GForum::Post'> will compile the code ref in the
|
||||
GForum::Post package. You need to do this to provide access to globals
|
||||
variables such as $DB, $IN, etc.
|
||||
|
||||
=item sort_order
|
||||
|
||||
If provided, the option will be passed through as the 'order' option of
|
||||
GT::Dumper for hash key ordering. See L<GT::Dumper>. GT::Config always sorts
|
||||
hash keys - this can be used when the default alphanumeric sort is not
|
||||
sufficient.
|
||||
|
||||
=back
|
||||
|
||||
=head2 save
|
||||
|
||||
To save a config file, simply call C<$object-E<gt>save()>. If the object uses
|
||||
inheritance, only those keys that were not inherited (or were modified from the
|
||||
inherited ones) will be saved.
|
||||
|
||||
$Config->save();
|
||||
|
||||
B<NOTE>: B<ALWAYS SAVE AFTER MAKING ANY CHANGES!!!>. If you do not save after
|
||||
making changes, the data retrieved from the cache may not be the same as the
|
||||
data stored in the configuration file on disk. After making ANY changes make
|
||||
absolutely sure that you either undo the change or save the configuration file.
|
||||
|
||||
=head2 cache_hit
|
||||
|
||||
Returns whether or not the current object was loaded from cache (1) or loaded
|
||||
from disk (undef).
|
||||
|
||||
=head2 inheritance
|
||||
|
||||
Returns the inheritance status (1 or 0) of the object.
|
||||
|
||||
=head2 create_ok
|
||||
|
||||
Returns the status (1 or 0) of the "create_ok" flag.
|
||||
|
||||
=head2 tmpfile
|
||||
|
||||
With no arguments, returns whether or not the object will attempt to use a
|
||||
temporary file when saving. Possible values are:
|
||||
|
||||
0 - Do not use a temporary file
|
||||
undef - Use a temporary file if the base directory is writable
|
||||
1 - Always use a temporary file
|
||||
|
||||
You can pass in a single argument of one of the above values to set whether or
|
||||
not the object will use a temporary file when saving.
|
||||
|
||||
=head2 cache
|
||||
|
||||
This method returns whether or not the object is cached. This cannot be
|
||||
enabled/disabled after loading a config file; you must specify it as an
|
||||
argument to C<load()> instead.
|
||||
|
||||
=head2 debug_level
|
||||
|
||||
This method returns the current debug level.
|
||||
|
||||
You may provide one argument which sets a new debug level.
|
||||
|
||||
0 means no debugging, 1 means basic debugging, 2 means heavy debugging.
|
||||
|
||||
If setting a new debug level, the old debug level is returned.
|
||||
|
||||
=head2 header
|
||||
|
||||
This method returns or sets the header that will be printed when saving.
|
||||
|
||||
With no arguments, returns the header.
|
||||
|
||||
You may provide one argument which sets a new header. Keep in mind that the
|
||||
file must be Perl-compilable, so take care if doing anything other than
|
||||
comments.
|
||||
|
||||
If providing a new header, the old header is returned.
|
||||
|
||||
Note that the header may contain the value C<[localtime]>, which will be
|
||||
replaced with the return value of C<scalar localtime()> when saving.
|
||||
|
||||
=head2 sort_order
|
||||
|
||||
This method returns or sets a code reference to be passed through as the
|
||||
'order' option of GT::Dumper for hash key ordering. See L<GT::Dumper>.
|
||||
GT::Config always sorts hash keys - this can be used when the default
|
||||
alphanumeric sort is not sufficient.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Template::Inheritance>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1128
site/glist/lib/GT/Date.pm
Normal file
1128
site/glist/lib/GT/Date.pm
Normal file
File diff suppressed because it is too large
Load Diff
180
site/glist/lib/GT/Delay.pm
Normal file
180
site/glist/lib/GT/Delay.pm
Normal file
@ -0,0 +1,180 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Delay
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Delay.pm,v 1.4 2004/01/13 01:35:15 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic delayed-loading module wrapper.
|
||||
#
|
||||
|
||||
package GT::Delay;
|
||||
use strict;
|
||||
use Carp();
|
||||
|
||||
my %Delayed;
|
||||
|
||||
sub GT::Delay {
|
||||
# We don't define any subroutines in GT::Delay, since even ->new should be
|
||||
# allowed in some circumstances. Takes three arguments - the package to load
|
||||
# (i.e. 'GT::SQL'), the type of blessed reference used for that object ('HASH',
|
||||
# 'ARRAY', and 'SCALAR' are supported), and any number of arguments to pass
|
||||
# into the ->new method of the package.
|
||||
#
|
||||
my ($package, $type, @args) = @_;
|
||||
$type ||= 'HASH';
|
||||
$type eq 'HASH' || $type eq 'ARRAY' || $type eq 'SCALAR' or Carp::croak('Unknown bless type: ' . $type . '. See the GT::Delay manpage');
|
||||
|
||||
my $self = bless($type eq 'HASH' ? {} : $type eq 'ARRAY' ? [] : \my $foo);
|
||||
$Delayed{$self} = [$package, $type, \@args];
|
||||
$self;
|
||||
}
|
||||
|
||||
AUTOLOAD {
|
||||
# When a method is called we create a real object, copy it into $self, and
|
||||
# rebless $self into the package. This has to be done to get around a case
|
||||
# such as: my $foo = GT::Delay(...); my $bar = $foo; $bar->meth;
|
||||
# Even changing $_[0] would not affect $foo, and if $foo was used would result
|
||||
# in _two_ of the delayed modules.
|
||||
#
|
||||
my $self = $_[0];
|
||||
my ($package, $type, $args) = @{delete $Delayed{$self}};
|
||||
|
||||
(my $module = $package) =~ s|::|/|g;
|
||||
$module .= '.pm';
|
||||
require $module;
|
||||
|
||||
my $copy = $package->new(@$args);
|
||||
|
||||
eval {
|
||||
if ($type eq 'HASH') { %$self = %$copy }
|
||||
elsif ($type eq 'ARRAY') { @$self = @$copy }
|
||||
else { $$self = $$copy }
|
||||
};
|
||||
|
||||
$@ and Carp::croak("$package type does not appear to be $type. Delayed loading failed");
|
||||
|
||||
bless $self, ref $copy;
|
||||
|
||||
my $method = substr($GT::Delay::AUTOLOAD, rindex($GT::Delay::AUTOLOAD, ':') + 1);
|
||||
if (my $subref = $self->can($method)) {
|
||||
goto &$subref;
|
||||
}
|
||||
elsif ($self->can('AUTOLOAD')) {
|
||||
shift;
|
||||
$self->$method(@_);
|
||||
}
|
||||
else {
|
||||
Carp::croak(qq|Can't locate object method "$method" via package "| . ref($self) . '"');
|
||||
}
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
delete $Delayed{$_[0]} if exists $Delayed{$_[0]};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Delay - Generic delayed module loading
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Delay;
|
||||
|
||||
my $obj = GT::Delay('GT::Foo', 'HASH', foo => "bar", bar => 12);
|
||||
|
||||
... # time passes without using $obj
|
||||
|
||||
$obj->method();
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a simple way to handle delayed module loading in a fairly
|
||||
generic way. Your object will only be a very lightweight GT::Delay object
|
||||
until you call a method on it, at which point the desired module will be loaded,
|
||||
your object will be changed into an object of the desired type.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
There is only one usable function provided by this module, GT::Delay() (not
|
||||
GT::Delay::Delay as this module attempts to leave the GT::Delay namespace as
|
||||
empty as possible).
|
||||
|
||||
=head2 GT::Delay
|
||||
|
||||
GT::Delay is used to create a new delayed object. It takes at least two
|
||||
arguments. The first is the package to load, such as 'GT::Foo' to require
|
||||
GT/Foo.pm and create a new GT::Foo object. The second is the type of blessed
|
||||
data structure a 'GT::Foo' object really is. This can be one of either 'HASH',
|
||||
'ARRAY', or 'SCALAR'. Any additional arguments are kept and passed in as
|
||||
arguments to the new() method of the object when created.
|
||||
|
||||
The object type ('HASH', 'ARRAY', or 'SCALAR') is needed is to get around a
|
||||
caveat of references - if $a and $b both point to the same reference, $b cannot
|
||||
be changed from $a - which makes it impossible to just get a new object and
|
||||
replace $_[0] with that object, because although that would change one of
|
||||
either $a or $b, it wouldn't change the other and you could easily end up with
|
||||
two separate objects. When a method is called, the new object is created, then
|
||||
copied into the original object which is then reblessed into the desired
|
||||
package. This doesn't change either $a or $b, but rather changes the reference
|
||||
they point to. You have to pass the object type because the reference must be
|
||||
reblessed, but the underlying data type cannot change. Unfortunately, this
|
||||
approach has a few caveats of its own, listed below.
|
||||
|
||||
=head1 CAVEATS and LIMITATIONS
|
||||
|
||||
Modules that are created by a method other than new() are not supported.
|
||||
|
||||
Modules that use a namespace different from the module location are not
|
||||
supported. For example, a package Foo::Bar::Blah located in Foo/Bar.pm. If
|
||||
you have such a module that would benefit from delayed loading, you need to
|
||||
rethink your package/filename naming scheme, or not use this module. It _is_
|
||||
possible to do this with a hack such as:
|
||||
C<$INC{'Foo/Bar/Blah.pm'} = './Foo/Bar.pm';> - but other than for testing,
|
||||
doing such a thing is strongly discouraged.
|
||||
|
||||
Objects cannot have their elements directly accessed - for example,
|
||||
C<$obj-E<gt>{foo}>. But, since that is bad practise anyway, it isn't that much
|
||||
of a limitation. That said, objects _can_ be accessed directly _after_ any
|
||||
method has been called.
|
||||
|
||||
Modules that store a string or integer form of $self (GT::Config does this to
|
||||
store object attributes) will not work, since the working object will not be
|
||||
the same object create a new(), but rather a copy.
|
||||
|
||||
Modules with DESTROY methods that do things to references in $self (for
|
||||
example, C<delete $self-E<gt>{foo}-E<gt>{bar}> - though C<delete
|
||||
$self-E<gt>{foo}> would be safe) will most likely not work properly as the copy
|
||||
is not deep - i.e. references are copied as-is.
|
||||
|
||||
Along the same lines as the previous point, the first object will be destroyed
|
||||
before the first method call goes through, so modules that do things (e.g.
|
||||
delete files, close filehandles, etc.) in DESTROY will most likely not work.
|
||||
|
||||
Any module that doesn't fall into any of the points above will be perfectly
|
||||
well supported by this module.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Delay.pm,v 1.4 2004/01/13 01:35:15 jagerman Exp $
|
||||
|
||||
=cut
|
||||
384
site/glist/lib/GT/Dumper.pm
Normal file
384
site/glist/lib/GT/Dumper.pm
Normal file
@ -0,0 +1,384 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Dumper
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Dumper.pm,v 1.38 2005/02/18 04:44:33 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements a data dumper, useful for converting complex Perl
|
||||
# data structures to strings, which can then be eval()ed back to
|
||||
# the original value.
|
||||
#
|
||||
|
||||
package GT::Dumper;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw /$DEBUG $ATTRIBS $VERSION @EXPORT @ISA $EOL/;
|
||||
use GT::Base;
|
||||
use Exporter;
|
||||
|
||||
$EOL = "\n";
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.38 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
var => '$VAR',
|
||||
data => undef,
|
||||
sort => 1,
|
||||
order => undef,
|
||||
compress => undef,
|
||||
structure => undef,
|
||||
tab => ' '
|
||||
};
|
||||
@EXPORT = qw/Dumper/;
|
||||
@ISA = qw/Exporter GT::Base/;
|
||||
|
||||
sub Dumper {
|
||||
# -----------------------------------------------------------
|
||||
# Dumper acts similar to Dumper in Data::Dumper when called as a
|
||||
# class method. If called as a instance method it assumes you
|
||||
# have set the options for the dump and does not change them.
|
||||
# It only takes a single argument - the variable to dump.
|
||||
#
|
||||
my $self;
|
||||
if (@_ == 2 and UNIVERSAL::isa($_[0], __PACKAGE__)) {
|
||||
$self = shift;
|
||||
$self->{data} = shift;
|
||||
}
|
||||
elsif (@_ == 1) {
|
||||
$self = GT::Dumper->new(data => shift);
|
||||
}
|
||||
else {
|
||||
die "Bad args to Dumper()";
|
||||
}
|
||||
return $self->dump;
|
||||
}
|
||||
|
||||
sub dump {
|
||||
# -----------------------------------------------------------
|
||||
# my $dump = $class->dump(%opts);
|
||||
# --------------------------------
|
||||
# Returns the data structure specified in %opts flatened.
|
||||
# %opts is optional if you have created an object with the
|
||||
# options.
|
||||
#
|
||||
my $this = shift;
|
||||
|
||||
# See if options were passed in
|
||||
my $self;
|
||||
if (!ref $this) {
|
||||
$self = $this->new(@_);
|
||||
}
|
||||
else {
|
||||
$self = $this;
|
||||
if (@_) {
|
||||
my $data = $self->common_param(@_) or return $self->fatal(BADARGS => '$dumper->dump(%opts)');
|
||||
$self->set($data);
|
||||
}
|
||||
}
|
||||
|
||||
my $level = 0;
|
||||
my $ret = '';
|
||||
if ($self->{var} and not $self->{structure}) {
|
||||
$ret .= ($self->{compress} ? "$self->{var}=" : "$self->{var} = ");
|
||||
}
|
||||
$self->_dump_value($level + 1, $self->{data}, \$ret);
|
||||
$ret .= ';' unless $self->{structure};
|
||||
$ret .= $EOL unless $self->{structure} or $self->{compress};
|
||||
|
||||
return $ret ? $ret : 1;
|
||||
}
|
||||
|
||||
sub dump_structure {
|
||||
my ($self, $data) = @_;
|
||||
return $self->dump(structure => 1, data => $data);
|
||||
}
|
||||
|
||||
sub _dump_value {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to decide what to dump.
|
||||
#
|
||||
my ($self, $level, $val, $ret, $n) = @_;
|
||||
my $was;
|
||||
my $ref = ref $val;
|
||||
if ($ref and $val =~ /=/) { $self->_dump_obj( $level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'HASH') { $self->_dump_hash( $level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'ARRAY') { $self->_dump_array($level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'SCALAR' or $ref eq 'REF' or $ref eq 'LVALUE') {
|
||||
$self->_dump_scalar($level, $val, $ret)
|
||||
}
|
||||
elsif ($ref eq 'CODE') { $$ret .= 'sub { () }' }
|
||||
else { $$ret .= _escape($val) }
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_scalar {
|
||||
# -----------------------------------------------------------
|
||||
# Dump a scalar reference.
|
||||
#
|
||||
my ($self, $level, $val, $ret, $n) = @_;
|
||||
my $v = $$val;
|
||||
$$ret .= '\\';
|
||||
$self->_dump_value($level, $v, $ret, 1);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_hash {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to for through a hash and dump it.
|
||||
#
|
||||
my ($self, $level, $hash_ref, $ret) = @_;
|
||||
$$ret .= '{';
|
||||
my $lines;
|
||||
if ($self->{sort}) {
|
||||
for (sort { ref($self->{order}) eq 'CODE' ? $self->{order}->($a, $b, $hash_ref->{$a}, $hash_ref->{$b}) : $a cmp $b } keys %{$hash_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
my $key = _escape($_);
|
||||
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
||||
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
||||
}
|
||||
}
|
||||
else {
|
||||
for (keys %{$hash_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
my $key = _escape($_);
|
||||
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
||||
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
||||
}
|
||||
}
|
||||
$$ret .= $EOL if $lines and not $self->{compress};
|
||||
$$ret .= ($lines and not $self->{compress}) ? (($self->{tab} x (($level - 1) / 2)) . "}") : "}";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_array {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to for through an array and dump it.
|
||||
#
|
||||
my ($self, $level, $array_ref, $ret) = @_;
|
||||
$$ret .= "[";
|
||||
my $lines;
|
||||
for (@{$array_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
$self->_dump_value($level + 1, $_, $ret, 1);
|
||||
}
|
||||
$$ret .= ($lines and not $self->{compress}) ? $EOL.(($self->{tab} x (($level - 1) / 2)) . "]") : "]";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_obj {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to dump an object.
|
||||
#
|
||||
my ($self, $level, $obj, $ret) = @_;
|
||||
my $class = ref $obj;
|
||||
$$ret .= "bless(";
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
if ($obj =~ /ARRAY\(/) { $self->_dump_array($level + 2, \@{$obj}, $ret) }
|
||||
elsif ($obj =~ /HASH\(/) { $self->_dump_hash( $level + 2, \%{$obj}, $ret) }
|
||||
elsif ($obj =~ /SCALAR\(/ or $obj =~ /REF\(/ or $obj =~ /LVALUE\(/)
|
||||
{ $self->_dump_value($level + 2, $$obj, $ret) }
|
||||
$$ret .= ",";
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
$$ret .= _escape($class);
|
||||
$$ret .= $EOL.($self->{tab} x (($level - 1) / 2)) unless $self->{compress};
|
||||
$$ret .= ")";
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub _escape {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to escape a dumped value.
|
||||
my ($val) = @_;
|
||||
defined($val) or return 'undef';
|
||||
$val =~ s/('|\\(?=['\\]|$))/\\$1/g;
|
||||
return "'$val'";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Dumper - Convert Perl data structures into a string.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Dumper;
|
||||
print Dumper($complex_var);
|
||||
print GT::Dumper->dump ( var => '$MYVAR', data => $complex_var);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Dumper by default exports a method Dumper() which will
|
||||
behave similar to Data::Dumper's Dumper(). It differs in that
|
||||
it will only take a single argument, and the variable dumped
|
||||
will be $VAR instead of $VAR1. Also, to provide easier control
|
||||
to change the variable name that gets dumped, you can use:
|
||||
|
||||
GT::Dumper->dump ( var => string, data => yourdata );
|
||||
|
||||
and the dump will start with string = instead of $VAR = .
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
use GT::Dumper;
|
||||
my %foo;
|
||||
my @bar = (1, 2, 3);
|
||||
$foo{alpha} = \@bar;
|
||||
$foo{beta} = 'a string';
|
||||
print Dumper(\%foo);
|
||||
|
||||
This will print:
|
||||
|
||||
$VAR = {
|
||||
'beta' => 'a string',
|
||||
'alpha' => [
|
||||
'1',
|
||||
'2',
|
||||
'3',
|
||||
],
|
||||
};
|
||||
|
||||
=head1 METHODS/FUNCTIONS
|
||||
|
||||
=head2 Dumper
|
||||
|
||||
Dumper() is exported by default when using GT::Dumper. It takes a single
|
||||
variable and returns a string representation of the variable. The string can
|
||||
then be eval()'ed back into the same data structure.
|
||||
|
||||
It takes only one argument - the variable to dump. The return is a string of
|
||||
the form:
|
||||
|
||||
$VAR = DATA
|
||||
|
||||
where 'DATA' is the actual data structure of the variable. A more powerful and
|
||||
customizable dumping method is the L</"dump"> method.
|
||||
|
||||
=head2 dump
|
||||
|
||||
dump() provides a more customizable method to dumping a data structure. Through
|
||||
the various options available, listed below, the output of a data structure
|
||||
dump can be formatted in several different ways.
|
||||
|
||||
The options are as follows. Only the L</"data"> option is required.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * data
|
||||
|
||||
The data option takes a data structure to dump. It is required.
|
||||
|
||||
=item * var
|
||||
|
||||
By default, a dump is output as an assignment to C<$VAR>. For example, dumping
|
||||
the string C<foo> would return: C<$VAR = 'foo'>. You can change and even omit
|
||||
the assignment using the C<var> option. To specify a different variable, you
|
||||
simply specify it as the value here. To have 'foo' dump as just C<'foo'>
|
||||
instead of C<$VAR = 'foo'>, specify var as an empty string, or undef.
|
||||
|
||||
=item * tab
|
||||
|
||||
When indenting for complex data structures (array refs, hash refs, etc.) an
|
||||
indent is used. By default, the indent is 4 spaces, however you can change this
|
||||
by using the C<tab> option.
|
||||
|
||||
=item * sort
|
||||
|
||||
The C<sort> option enables hash key sorting. It is not on by default - to
|
||||
enable, simply specify the sort option with 1 as the value. The default sort
|
||||
method is case-sensitive alphabetical. See the L</"order"> option for
|
||||
specifying your own sort order.
|
||||
|
||||
=item * order
|
||||
|
||||
When sorting, it is sometimes desirable to use a custom sort order rather than
|
||||
the default case-sensitive alphabetical sort. The C<order> option takes a code
|
||||
reference and enables custom sort ordering. The code reference will be passed 4
|
||||
variables. The first and second are the two items being compared - $a and $b in
|
||||
Perl's sort mechanism. The third and fourth are the values in the hash being
|
||||
sorted. The code reference, like a Perl sort routine, should return -1 if $a
|
||||
should come before $b, 0 if $a and $b are equivelant in your sort order, and 1
|
||||
if $b should come before $a. Because of scoping and package issues in Perl, it
|
||||
is not possible to directly use $a and $b.
|
||||
|
||||
=item * compress
|
||||
|
||||
The default dump method is to use ' => ' between hash key and value, to use
|
||||
indenting, and to add a line break after each dumped element. You can turn all
|
||||
of these off by using the compress option.
|
||||
|
||||
Compression removes all non-essential characters from the output, thus reducing
|
||||
data size, however also generally making the dump very difficult to read. If
|
||||
enabled, the dumping behaviour is changed as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * assignment
|
||||
|
||||
If using a var (ie. C<$VAR = DATA>), the spaces around the = will be stripped.
|
||||
The output will look like: C<$VAR=DATA>
|
||||
|
||||
=item * hash keys
|
||||
|
||||
Instead of placing the 4 characters ' => ' between hash keys and values, a
|
||||
single ',' will be used.
|
||||
|
||||
=item * tabs
|
||||
|
||||
Tabs will not be used.
|
||||
|
||||
=item * newlines
|
||||
|
||||
Normally, a newline character is added after each dumped element. Compress
|
||||
turns this off.
|
||||
|
||||
=back
|
||||
|
||||
=item * structure
|
||||
|
||||
The structure option causes the dump to be a valid perl structure rather than a
|
||||
valid perl statement. This differs in two ways - for one, the C<var> option is
|
||||
ignored - it is treated as if a blank C<var> was entered, thereby not returning
|
||||
an assignment. The other difference is that an an ordinary dump adds a
|
||||
semicolon and newline at the end of the dump, but these are not added when the
|
||||
structure option is enabled.
|
||||
|
||||
=back
|
||||
|
||||
=head2 dump_structure
|
||||
|
||||
This is a quick method to do a structure dump. It takes one argument - the data
|
||||
to dump. Calling:
|
||||
$class->dump_structure($DATA);
|
||||
is identical to calling:
|
||||
$class->dump(data => $DATA, structure => 1);
|
||||
See the L</"structure"> option.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Dumper>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Dumper.pm,v 1.38 2005/02/18 04:44:33 jagerman Exp $
|
||||
|
||||
=cut
|
||||
865
site/glist/lib/GT/File/Diff.pm
Normal file
865
site/glist/lib/GT/File/Diff.pm
Normal file
@ -0,0 +1,865 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::File::Diff
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Diff.pm,v 1.2 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic diff module.
|
||||
# This module is based entirely on Algorithm::Diff v1.15.
|
||||
#
|
||||
package GT::File::Diff;
|
||||
|
||||
use vars qw($VERSION @EXPORT_OK @ISA @EXPORT);
|
||||
use integer; # see below in _replaceNextLargerWith() for mod to make
|
||||
# if you don't use this
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw();
|
||||
@EXPORT_OK = qw(LCS diff traverse_sequences traverse_balanced sdiff);
|
||||
$VERSION = sprintf('%d.%02d', (q$Revision: 1.2 $ =~ /\d+/g));
|
||||
|
||||
# McIlroy-Hunt diff algorithm
|
||||
# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
|
||||
# by Ned Konz, perl@bike-nomad.com
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Algorithm::Diff - Compute `intelligent' differences between two files / lists
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::File::Diff qw(diff sdiff LCS traverse_sequences
|
||||
traverse_balanced);
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2 );
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
$lcsref = LCS( \@seq1, \@seq2 );
|
||||
|
||||
$lcsref = LCS( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2 );
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2 );
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
} );
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
},
|
||||
$key_generation_function );
|
||||
|
||||
traverse_balanced( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
CHANGE => $callback,
|
||||
} );
|
||||
|
||||
=head1 INTRODUCTION
|
||||
|
||||
(by Mark-Jason Dominus)
|
||||
|
||||
I once read an article written by the authors of C<diff>; they said
|
||||
that they hard worked very hard on the algorithm until they found the
|
||||
right one.
|
||||
|
||||
I think what they ended up using (and I hope someone will correct me,
|
||||
because I am not very confident about this) was the `longest common
|
||||
subsequence' method. in the LCS problem, you have two sequences of
|
||||
items:
|
||||
|
||||
a b c d f g h j q z
|
||||
|
||||
a b c d e f g i j k r x y z
|
||||
|
||||
and you want to find the longest sequence of items that is present in
|
||||
both original sequences in the same order. That is, you want to find
|
||||
a new sequence I<S> which can be obtained from the first sequence by
|
||||
deleting some items, and from the secend sequence by deleting other
|
||||
items. You also want I<S> to be as long as possible. In this case
|
||||
I<S> is
|
||||
|
||||
a b c d f g j z
|
||||
|
||||
From there it's only a small step to get diff-like output:
|
||||
|
||||
e h i k q r x y
|
||||
+ - + + - + + +
|
||||
|
||||
This module solves the LCS problem. It also includes a canned
|
||||
function to generate C<diff>-like output.
|
||||
|
||||
It might seem from the example above that the LCS of two sequences is
|
||||
always pretty obvious, but that's not always the case, especially when
|
||||
the two sequences have many repeated elements. For example, consider
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a x b y c z
|
||||
|
||||
A naive approach might start by matching up the C<a> and C<b> that
|
||||
appear at the beginning of each sequence, like this:
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a b y c z
|
||||
|
||||
This finds the common subsequence C<a b c z>. But actually, the LCS
|
||||
is C<a x b y c z>:
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a x b y c z
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
This module provides three exportable functions, which we'll deal with in
|
||||
ascending order of difficulty: C<LCS>,
|
||||
C<diff>, C<sdiff>, C<traverse_sequences>, and C<traverse_balanced>.
|
||||
|
||||
=head2 C<LCS>
|
||||
|
||||
Given references to two lists of items, LCS returns an array containing their
|
||||
longest common subsequence. In scalar context, it returns a reference to
|
||||
such a list.
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2 );
|
||||
$lcsref = LCS( \@seq1, \@seq2 );
|
||||
|
||||
C<LCS> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2, $keyGen );
|
||||
$lcsref = LCS( \@seq1, \@seq2, $keyGen );
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<diff>
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2 );
|
||||
$diffs_ref = diff( \@seq1, \@seq2 );
|
||||
|
||||
C<diff> computes the smallest set of additions and deletions necessary
|
||||
to turn the first sequence into the second, and returns a description
|
||||
of these changes. The description is a list of I<hunks>; each hunk
|
||||
represents a contiguous section of items which should be added,
|
||||
deleted, or replaced. The return value of C<diff> is a list of
|
||||
hunks, or, in scalar context, a reference to such a list.
|
||||
|
||||
Here is an example: The diff of the following two sequences:
|
||||
|
||||
a b c e h j l m n p
|
||||
b c d e f j k l m r s t
|
||||
|
||||
Result:
|
||||
|
||||
[
|
||||
[ [ '-', 0, 'a' ] ],
|
||||
|
||||
[ [ '+', 2, 'd' ] ],
|
||||
|
||||
[ [ '-', 4, 'h' ] ,
|
||||
[ '+', 4, 'f' ] ],
|
||||
|
||||
[ [ '+', 6, 'k' ] ],
|
||||
|
||||
[ [ '-', 8, 'n' ],
|
||||
[ '-', 9, 'p' ],
|
||||
[ '+', 9, 'r' ],
|
||||
[ '+', 10, 's' ],
|
||||
[ '+', 11, 't' ],
|
||||
]
|
||||
]
|
||||
|
||||
There are five hunks here. The first hunk says that the C<a> at
|
||||
position 0 of the first sequence should be deleted (C<->). The second
|
||||
hunk says that the C<d> at position 2 of the second sequence should
|
||||
be inserted (C<+>). The third hunk says that the C<h> at position 4
|
||||
of the first sequence should be removed and replaced with the C<f>
|
||||
from position 4 of the second sequence. The other two hunks similarly.
|
||||
|
||||
C<diff> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<sdiff>
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2 );
|
||||
$sdiffs_ref = sdiff( \@seq1, \@seq2 );
|
||||
|
||||
C<sdiff> computes all necessary components to show two sequences
|
||||
and their minimized differences side by side, just like the
|
||||
Unix-utility I<sdiff> does:
|
||||
|
||||
same same
|
||||
before | after
|
||||
old < -
|
||||
- > new
|
||||
|
||||
It returns a list of array refs, each pointing to an array of
|
||||
display instructions. In scalar context it returns a reference
|
||||
to such a list.
|
||||
|
||||
Display instructions consist of three elements: A modifier indicator
|
||||
(C<+>: Element added, C<->: Element removed, C<u>: Element unmodified,
|
||||
C<c>: Element changed) and the value of the old and new elements, to
|
||||
be displayed side by side.
|
||||
|
||||
An C<sdiff> of the following two sequences:
|
||||
|
||||
a b c e h j l m n p
|
||||
b c d e f j k l m r s t
|
||||
|
||||
results in
|
||||
|
||||
[ [ '-', 'a', '' ],
|
||||
[ 'u', 'b', 'b' ],
|
||||
[ 'u', 'c', 'c' ],
|
||||
[ '+', '', 'd' ],
|
||||
[ 'u', 'e', 'e' ],
|
||||
[ 'c', 'h', 'f' ],
|
||||
[ 'u', 'j', 'j' ],
|
||||
[ '+', '', 'k' ],
|
||||
[ 'u', 'l', 'l' ],
|
||||
[ 'u', 'm', 'm' ],
|
||||
[ 'c', 'n', 'r' ],
|
||||
[ 'c', 'p', 's' ],
|
||||
[ '+', '', 't' ] ]
|
||||
|
||||
C<sdiff> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<traverse_sequences>
|
||||
|
||||
C<traverse_sequences> is the most general facility provided by this
|
||||
module; C<diff> and C<LCS> are implemented as calls to it.
|
||||
|
||||
Imagine that there are two arrows. Arrow A points to an element of sequence A,
|
||||
and arrow B points to an element of the sequence B. Initially, the arrows
|
||||
point to the first elements of the respective sequences. C<traverse_sequences>
|
||||
will advance the arrows through the sequences one element at a time, calling an
|
||||
appropriate user-specified callback function before each advance. It
|
||||
willadvance the arrows in such a way that if there are equal elements C<$A[$i]>
|
||||
and C<$B[$j]> which are equal and which are part of the LCS, there will be
|
||||
some moment during the execution of C<traverse_sequences> when arrow A is
|
||||
pointing to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this happens,
|
||||
C<traverse_sequences> will call the C<MATCH> callback function and then it will
|
||||
advance both arrows.
|
||||
|
||||
Otherwise, one of the arrows is pointing to an element of its sequence that is
|
||||
not part of the LCS. C<traverse_sequences> will advance that arrow and will
|
||||
call the C<DISCARD_A> or the C<DISCARD_B> callback, depending on which arrow it
|
||||
advanced. If both arrows point to elements that are not part of the LCS, then
|
||||
C<traverse_sequences> will advance one of them and call the appropriate
|
||||
callback, but it is not specified which it will call.
|
||||
|
||||
The arguments to C<traverse_sequences> are the two sequences to traverse, and a
|
||||
hash which specifies the callback functions, like this:
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback_1,
|
||||
DISCARD_A => $callback_2,
|
||||
DISCARD_B => $callback_3,
|
||||
} );
|
||||
|
||||
Callbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least the
|
||||
indices of the two arrows as their arguments. They are not expected to return
|
||||
any values. If a callback is omitted from the table, it is not called.
|
||||
|
||||
Callbacks for A_FINISHED and B_FINISHED are invoked with at least the
|
||||
corresponding index in A or B.
|
||||
|
||||
If arrow A reaches the end of its sequence, before arrow B does,
|
||||
C<traverse_sequences> will call the C<A_FINISHED> callback when it advances
|
||||
arrow B, if there is such a function; if not it will call C<DISCARD_B> instead.
|
||||
Similarly if arrow B finishes first. C<traverse_sequences> returns when both
|
||||
arrows are at the ends of their respective sequences. It returns true on
|
||||
success and false on failure. At present there is no way to fail.
|
||||
|
||||
C<traverse_sequences> may be passed an optional fourth parameter; this is a
|
||||
CODE reference to a key generation function. See L</KEY GENERATION FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation function.
|
||||
|
||||
=head2 C<traverse_balanced>
|
||||
|
||||
C<traverse_balanced> is an alternative to C<traverse_sequences>. It
|
||||
uses a different algorithm to iterate through the entries in the
|
||||
computed LCS. Instead of sticking to one side and showing element changes
|
||||
as insertions and deletions only, it will jump back and forth between
|
||||
the two sequences and report I<changes> occurring as deletions on one
|
||||
side followed immediatly by an insertion on the other side.
|
||||
|
||||
In addition to the
|
||||
C<DISCARD_A>,
|
||||
C<DISCARD_B>, and
|
||||
C<MATCH>
|
||||
callbacks supported by C<traverse_sequences>, C<traverse_balanced> supports
|
||||
a C<CHANGE> callback indicating that one element got C<replaced> by another:
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback_1,
|
||||
DISCARD_A => $callback_2,
|
||||
DISCARD_B => $callback_3,
|
||||
CHANGE => $callback_4,
|
||||
} );
|
||||
|
||||
If no C<CHANGE> callback is specified, C<traverse_balanced>
|
||||
will map C<CHANGE> events to C<DISCARD_A> and C<DISCARD_B> actions,
|
||||
therefore resulting in a similar behaviour as C<traverse_sequences>
|
||||
with different order of events.
|
||||
|
||||
C<traverse_balanced> might be a bit slower than C<traverse_sequences>,
|
||||
noticable only while processing huge amounts of data.
|
||||
|
||||
The C<sdiff> function of this module
|
||||
is implemented as call to C<traverse_balanced>.
|
||||
|
||||
=head1 KEY GENERATION FUNCTIONS
|
||||
|
||||
C<diff>, C<LCS>, and C<traverse_sequences> accept an optional last parameter.
|
||||
This is a CODE reference to a key generating (hashing) function that should
|
||||
return a string that uniquely identifies a given element. It should be the
|
||||
case that if two elements are to be considered equal, their keys should be the
|
||||
same (and the other way around). If no key generation function is provided,
|
||||
the key will be the element as a string.
|
||||
|
||||
By default, comparisons will use "eq" and elements will be turned into keys
|
||||
using the default stringizing operator '""'.
|
||||
|
||||
Where this is important is when you're comparing something other than strings.
|
||||
If it is the case that you have multiple different objects that should be
|
||||
considered to be equal, you should supply a key generation function. Otherwise,
|
||||
you have to make sure that your arrays contain unique references.
|
||||
|
||||
For instance, consider this example:
|
||||
|
||||
package Person;
|
||||
|
||||
sub new
|
||||
{
|
||||
my $package = shift;
|
||||
return bless { name => '', ssn => '', @_ }, $package;
|
||||
}
|
||||
|
||||
sub clone
|
||||
{
|
||||
my $old = shift;
|
||||
my $new = bless { %$old }, ref($old);
|
||||
}
|
||||
|
||||
sub hash
|
||||
{
|
||||
return shift()->{'ssn'};
|
||||
}
|
||||
|
||||
my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );
|
||||
my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );
|
||||
my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );
|
||||
my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );
|
||||
my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );
|
||||
|
||||
If you did this:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4, $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2 );
|
||||
|
||||
everything would work out OK (each of the objects would be converted
|
||||
into a string like "Person=HASH(0x82425b0)" for comparison).
|
||||
|
||||
But if you did this:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2 );
|
||||
|
||||
$person4 and $person4->clone() (which have the same name and SSN)
|
||||
would be seen as different objects. If you wanted them to be considered
|
||||
equivalent, you would have to pass in a key generation function:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2, \&Person::hash );
|
||||
|
||||
This would use the 'ssn' field in each Person as a comparison key, and
|
||||
so would consider $person4 and $person4->clone() as equal.
|
||||
|
||||
You may also pass additional parameters to the key generation function
|
||||
if you wish.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This version by Ned Konz, perl@bike-nomad.com
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (c) 2000-2002 Ned Konz. All rights reserved.
|
||||
This program is free software;
|
||||
you can redistribute it and/or modify it under the same terms
|
||||
as Perl itself.
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Versions through 0.59 (and much of this documentation) were written by:
|
||||
|
||||
Mark-Jason Dominus, mjd-perl-diff@plover.com
|
||||
|
||||
This version borrows the documentation and names of the routines
|
||||
from Mark-Jason's, but has all new code in Diff.pm.
|
||||
|
||||
This code was adapted from the Smalltalk code of
|
||||
Mario Wolczko <mario@wolczko.com>, which is available at
|
||||
ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
|
||||
|
||||
C<sdiff> and C<traverse_balanced> were written by Mike Schilli
|
||||
<m@perlmeister.com>.
|
||||
|
||||
The algorithm is that described in
|
||||
I<A Fast Algorithm for Computing Longest Common Subsequences>,
|
||||
CACM, vol.20, no.5, pp.350-353, May 1977, with a few
|
||||
minor improvements to improve the speed.
|
||||
|
||||
=cut
|
||||
|
||||
# Create a hash that maps each element of $aCollection to the set of positions
|
||||
# it occupies in $aCollection, restricted to the elements within the range of
|
||||
# indexes specified by $start and $end.
|
||||
# The fourth parameter is a subroutine reference that will be called to
|
||||
# generate a string to use as a key.
|
||||
# Additional parameters, if any, will be passed to this subroutine.
|
||||
#
|
||||
# my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
|
||||
|
||||
sub _withPositionsOfInInterval
|
||||
{
|
||||
my $aCollection = shift; # array ref
|
||||
my $start = shift;
|
||||
my $end = shift;
|
||||
my $keyGen = shift;
|
||||
my %d;
|
||||
my $index;
|
||||
for ( $index = $start ; $index <= $end ; $index++ )
|
||||
{
|
||||
my $element = $aCollection->[$index];
|
||||
my $key = &$keyGen( $element, @_ );
|
||||
if ( exists( $d{$key} ) )
|
||||
{
|
||||
unshift ( @{ $d{$key} }, $index );
|
||||
}
|
||||
else
|
||||
{
|
||||
$d{$key} = [$index];
|
||||
}
|
||||
}
|
||||
return wantarray ? %d : \%d;
|
||||
}
|
||||
|
||||
# Find the place at which aValue would normally be inserted into the array. If
|
||||
# that place is already occupied by aValue, do nothing, and return undef. If
|
||||
# the place does not exist (i.e., it is off the end of the array), add it to
|
||||
# the end, otherwise replace the element at that point with aValue.
|
||||
# It is assumed that the array's values are numeric.
|
||||
# This is where the bulk (75%) of the time is spent in this module, so try to
|
||||
# make it fast!
|
||||
|
||||
sub _replaceNextLargerWith
|
||||
{
|
||||
my ( $array, $aValue, $high ) = @_;
|
||||
$high ||= $#$array;
|
||||
|
||||
# off the end?
|
||||
if ( $high == -1 || $aValue > $array->[-1] )
|
||||
{
|
||||
push ( @$array, $aValue );
|
||||
return $high + 1;
|
||||
}
|
||||
|
||||
# binary search for insertion point...
|
||||
my $low = 0;
|
||||
my $index;
|
||||
my $found;
|
||||
while ( $low <= $high )
|
||||
{
|
||||
$index = ( $high + $low ) / 2;
|
||||
|
||||
# $index = int(( $high + $low ) / 2); # without 'use integer'
|
||||
$found = $array->[$index];
|
||||
|
||||
if ( $aValue == $found )
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
elsif ( $aValue > $found )
|
||||
{
|
||||
$low = $index + 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
$high = $index - 1;
|
||||
}
|
||||
}
|
||||
|
||||
# now insertion point is in $low.
|
||||
$array->[$low] = $aValue; # overwrite next larger
|
||||
return $low;
|
||||
}
|
||||
|
||||
# This method computes the longest common subsequence in $a and $b.
|
||||
|
||||
# Result is array or ref, whose contents is such that
|
||||
# $a->[ $i ] == $b->[ $result[ $i ] ]
|
||||
# foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
|
||||
|
||||
# An additional argument may be passed; this is a hash or key generating
|
||||
# function that should return a string that uniquely identifies the given
|
||||
# element. It should be the case that if the key is the same, the elements
|
||||
# will compare the same. If this parameter is undef or missing, the key
|
||||
# will be the element as a string.
|
||||
|
||||
# By default, comparisons will use "eq" and elements will be turned into keys
|
||||
# using the default stringizing operator '""'.
|
||||
|
||||
# Additional parameters, if any, will be passed to the key generation routine.
|
||||
|
||||
sub _longestCommonSubsequence
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $keyGen = shift; # code ref
|
||||
my $compare; # code ref
|
||||
|
||||
# set up code refs
|
||||
# Note that these are optimized.
|
||||
if ( !defined($keyGen) ) # optimize for strings
|
||||
{
|
||||
$keyGen = sub { $_[0] };
|
||||
$compare = sub { my ( $a, $b ) = @_; $a eq $b };
|
||||
}
|
||||
else
|
||||
{
|
||||
$compare = sub {
|
||||
my $a = shift;
|
||||
my $b = shift;
|
||||
&$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
|
||||
};
|
||||
}
|
||||
|
||||
my ( $aStart, $aFinish, $bStart, $bFinish, $matchVector ) =
|
||||
( 0, $#$a, 0, $#$b, [] );
|
||||
|
||||
# First we prune off any common elements at the beginning
|
||||
while ( $aStart <= $aFinish
|
||||
and $bStart <= $bFinish
|
||||
and &$compare( $a->[$aStart], $b->[$bStart], @_ ) )
|
||||
{
|
||||
$matchVector->[ $aStart++ ] = $bStart++;
|
||||
}
|
||||
|
||||
# now the end
|
||||
while ( $aStart <= $aFinish
|
||||
and $bStart <= $bFinish
|
||||
and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) )
|
||||
{
|
||||
$matchVector->[ $aFinish-- ] = $bFinish--;
|
||||
}
|
||||
|
||||
# Now compute the equivalence classes of positions of elements
|
||||
my $bMatches =
|
||||
_withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
|
||||
my $thresh = [];
|
||||
my $links = [];
|
||||
|
||||
my ( $i, $ai, $j, $k );
|
||||
for ( $i = $aStart ; $i <= $aFinish ; $i++ )
|
||||
{
|
||||
$ai = &$keyGen( $a->[$i], @_ );
|
||||
if ( exists( $bMatches->{$ai} ) )
|
||||
{
|
||||
$k = 0;
|
||||
for $j ( @{ $bMatches->{$ai} } )
|
||||
{
|
||||
|
||||
# optimization: most of the time this will be true
|
||||
if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
|
||||
{
|
||||
$thresh->[$k] = $j;
|
||||
}
|
||||
else
|
||||
{
|
||||
$k = _replaceNextLargerWith( $thresh, $j, $k );
|
||||
}
|
||||
|
||||
# oddly, it's faster to always test this (CPU cache?).
|
||||
if ( defined($k) )
|
||||
{
|
||||
$links->[$k] =
|
||||
[ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (@$thresh)
|
||||
{
|
||||
for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
|
||||
{
|
||||
$matchVector->[ $link->[1] ] = $link->[2];
|
||||
}
|
||||
}
|
||||
|
||||
return wantarray ? @$matchVector : $matchVector;
|
||||
}
|
||||
|
||||
sub traverse_sequences
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $callbacks = shift || {};
|
||||
my $keyGen = shift;
|
||||
my $matchCallback = $callbacks->{'MATCH'} || sub { };
|
||||
my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
|
||||
my $finishedACallback = $callbacks->{'A_FINISHED'};
|
||||
my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
|
||||
my $finishedBCallback = $callbacks->{'B_FINISHED'};
|
||||
my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
|
||||
|
||||
# Process all the lines in @$matchVector
|
||||
my $lastA = $#$a;
|
||||
my $lastB = $#$b;
|
||||
my $bi = 0;
|
||||
my $ai;
|
||||
|
||||
for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
|
||||
{
|
||||
my $bLine = $matchVector->[$ai];
|
||||
if ( defined($bLine) ) # matched
|
||||
{
|
||||
&$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
|
||||
&$matchCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai, $bi, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
# The last entry (if any) processed was a match.
|
||||
# $ai and $bi point just past the last matching lines in their sequences.
|
||||
|
||||
while ( $ai <= $lastA or $bi <= $lastB )
|
||||
{
|
||||
|
||||
# last A?
|
||||
if ( $ai == $lastA + 1 and $bi <= $lastB )
|
||||
{
|
||||
if ( defined($finishedACallback) )
|
||||
{
|
||||
&$finishedACallback( $lastA, @_ );
|
||||
$finishedACallback = undef;
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
|
||||
}
|
||||
}
|
||||
|
||||
# last B?
|
||||
if ( $bi == $lastB + 1 and $ai <= $lastA )
|
||||
{
|
||||
if ( defined($finishedBCallback) )
|
||||
{
|
||||
&$finishedBCallback( $lastB, @_ );
|
||||
$finishedBCallback = undef;
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
|
||||
}
|
||||
}
|
||||
|
||||
&$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
|
||||
&$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub traverse_balanced
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $callbacks = shift || {};
|
||||
my $keyGen = shift;
|
||||
my $matchCallback = $callbacks->{'MATCH'} || sub { };
|
||||
my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
|
||||
my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
|
||||
my $changeCallback = $callbacks->{'CHANGE'};
|
||||
my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
|
||||
|
||||
# Process all the lines in match vector
|
||||
my $lastA = $#$a;
|
||||
my $lastB = $#$b;
|
||||
my $bi = 0;
|
||||
my $ai = 0;
|
||||
my $ma = -1;
|
||||
my $mb;
|
||||
|
||||
while (1)
|
||||
{
|
||||
|
||||
# Find next match indices $ma and $mb
|
||||
do { $ma++ } while ( $ma <= $#$matchVector && !defined $matchVector->[$ma] );
|
||||
|
||||
last if $ma > $#$matchVector; # end of matchVector?
|
||||
$mb = $matchVector->[$ma];
|
||||
|
||||
# Proceed with discard a/b or change events until
|
||||
# next match
|
||||
while ( $ai < $ma || $bi < $mb )
|
||||
{
|
||||
|
||||
if ( $ai < $ma && $bi < $mb )
|
||||
{
|
||||
|
||||
# Change
|
||||
if ( defined $changeCallback )
|
||||
{
|
||||
&$changeCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
elsif ( $ai < $ma )
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
|
||||
# $bi < $mb
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
# Match
|
||||
&$matchCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
|
||||
while ( $ai <= $lastA || $bi <= $lastB )
|
||||
{
|
||||
if ( $ai <= $lastA && $bi <= $lastB )
|
||||
{
|
||||
|
||||
# Change
|
||||
if ( defined $changeCallback )
|
||||
{
|
||||
&$changeCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
elsif ( $ai <= $lastA )
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
|
||||
# $bi <= $lastB
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub LCS
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $matchVector = _longestCommonSubsequence( $a, @_ );
|
||||
my @retval;
|
||||
my $i;
|
||||
for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
|
||||
{
|
||||
if ( defined( $matchVector->[$i] ) )
|
||||
{
|
||||
push ( @retval, $a->[$i] );
|
||||
}
|
||||
}
|
||||
return wantarray ? @retval : \@retval;
|
||||
}
|
||||
|
||||
sub diff
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $retval = [];
|
||||
my $hunk = [];
|
||||
my $discard = sub { push ( @$hunk, [ '-', $_[0], $a->[ $_[0] ] ] ) };
|
||||
my $add = sub { push ( @$hunk, [ '+', $_[1], $b->[ $_[1] ] ] ) };
|
||||
my $match = sub { push ( @$retval, $hunk ) if scalar(@$hunk); $hunk = [] };
|
||||
traverse_sequences( $a, $b,
|
||||
{ MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
|
||||
&$match();
|
||||
return wantarray ? @$retval : $retval;
|
||||
}
|
||||
|
||||
sub sdiff
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $retval = [];
|
||||
my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
|
||||
my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
|
||||
my $change = sub {
|
||||
push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
|
||||
};
|
||||
my $match = sub {
|
||||
push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
|
||||
};
|
||||
traverse_balanced(
|
||||
$a,
|
||||
$b,
|
||||
{
|
||||
MATCH => $match,
|
||||
DISCARD_A => $discard,
|
||||
DISCARD_B => $add,
|
||||
CHANGE => $change,
|
||||
},
|
||||
@_
|
||||
);
|
||||
return wantarray ? @$retval : $retval;
|
||||
}
|
||||
|
||||
1;
|
||||
1507
site/glist/lib/GT/File/Tools.pm
Normal file
1507
site/glist/lib/GT/File/Tools.pm
Normal file
File diff suppressed because it is too large
Load Diff
285
site/glist/lib/GT/FileMan.pm
Normal file
285
site/glist/lib/GT/FileMan.pm
Normal file
@ -0,0 +1,285 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: FileMan.pm,v 1.121 2005/04/11 17:24:03 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
package GT::FileMan;
|
||||
#--------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $DEBUG $HAVE_GZIP $HAVE_AZIP $UNSAFE_PATH/;
|
||||
use GT::Base qw/:persist/;
|
||||
use GT::Template;
|
||||
use GT::FileMan::Commands;
|
||||
|
||||
# Check if Compress::Zlib is available
|
||||
$HAVE_GZIP = eval { local $SIG{__DIE__}; require Compress::Zlib; 1; } ? 1 : 0;
|
||||
|
||||
# Check if Archive::Zip is available
|
||||
$HAVE_AZIP = eval { local $SIG{__DIE__}; require Archive::Zip; 1; } ? 1 : 0;
|
||||
|
||||
$DEBUG = 0;
|
||||
|
||||
@ISA = qw/GT::FileMan::Commands GT::Base/;
|
||||
|
||||
$UNSAFE_PATH = $^O =~ /mswin/i ? '(^|[/\\\\])\.\.?($|[/\\\\])' : '(^|/)\.\.?($|/)';
|
||||
|
||||
sub new {
|
||||
# ------------------------------------------------------------------
|
||||
# Constructor
|
||||
#
|
||||
my ($class,%args) = @_;
|
||||
my $self = bless {%args}, ref $class || $class;
|
||||
|
||||
$self->{cfg} = $self->load_config() if (!$self->{cfg});
|
||||
$self->{cfg}->{winnt} = $^O eq 'MSWin32' ? 1 : 0;
|
||||
$self->{cfg}->{upload_chmod} ||= '644';
|
||||
$self->{cfg}->{template_root} or die('You must pass in your template root !');
|
||||
$self->{cfg}->{root_dir} or die('You must set your root dir !');
|
||||
|
||||
$self->{in} = new GT::CGI;
|
||||
$self->{cgi} = $self->{in}->get_hash;
|
||||
|
||||
my $passwd_dir = $self->{passwd_dir};
|
||||
if ($passwd_dir and !$self->{in}->cookie('def_passwd_dir')) { #store the password directory to cookie
|
||||
$passwd_dir = "$self->{cfg}->{root_dir}/$passwd_dir" if ($self->{cfg}->{passwd_dir_level}); # must be inside root directory
|
||||
|
||||
(-e $passwd_dir and -w _) or die("$passwd_dir does not exist or not writeable");
|
||||
print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name => 'def_passwd_dir', -value => $passwd_dir, -expires => '+5y') ]);
|
||||
}
|
||||
|
||||
# Set our default working directory.
|
||||
$self->{work_path} = $self->{cgi}->{work_path};
|
||||
if ($self->{cgi}->{def_load} and !$self->{cgi}->{work_path}) {
|
||||
$self->{work_path} = ($self->{in}->cookie('def_working_dir') eq '/') ? '' : $self->{in}->cookie('def_working_dir');
|
||||
(!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /$UNSAFE_PATH/)) or ($self->{work_path} = '');
|
||||
}
|
||||
$self->{work_path} ||= '';
|
||||
(!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /$UNSAFE_PATH/)) or die ("work_path has invalid characters : $self->{work_path} ");
|
||||
-e "$self->{cfg}->{root_dir}/$self->{work_path}" or ($self->{work_path} = '');
|
||||
|
||||
$self->{http_ref} = $self->{in}->url (absolute => 0, query_string => 0);
|
||||
$self->{results} = '';
|
||||
$self->{data} = {};
|
||||
$self->{status} = '';
|
||||
$self->{input} = '';
|
||||
$self->{debug} and ($DEBUG = $self->{debug});
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub process {
|
||||
# ------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $action = $self->{cgi}->{fdo} || $self->{cgi}->{cmd_do};
|
||||
|
||||
return $self->page("home.html") if (!$action or $action eq 'fileman');
|
||||
|
||||
my $command_enable = 1; # default is enable
|
||||
$command_enable = $self->{commands}->{$action} if (exists $self->{commands}->{$action});
|
||||
|
||||
# Determine what to do:
|
||||
if (exists $GT::FileMan::Commands::COMPILE{$action} and $command_enable) {
|
||||
$self->$action();
|
||||
}
|
||||
else {
|
||||
die "<font color=red>Invalid action or command is disable : $action !</font>";
|
||||
}
|
||||
}
|
||||
|
||||
sub page {
|
||||
# ------------------------------------------------------------------
|
||||
# Print out the requested template
|
||||
#
|
||||
my ($self, $file, $args) = @_;
|
||||
$file ||= $self->{cgi}->{page};
|
||||
print $self->{in}->header;
|
||||
|
||||
my $template_path = ($self->{cgi}->{t}) ? "$self->{cfg}->{template_root}/$self->{cgi}->{t}" : $self->{cfg}->{template_root};
|
||||
|
||||
# Check the file name requested.
|
||||
"$template_path/$file" =~ /\\/ and return die "Invalid template '$file' requested (Invalid name)";
|
||||
"$template_path/$file" =~ /$UNSAFE_PATH/ and return die "Invalid template '$file' requested (Invalid name)";
|
||||
$file =~ m,^\s*/, and return die "Invalid template '$file' requested (Invalid name)";
|
||||
-e "$template_path/$file" or return die "Invalid template '$template_path/$file' requested (File does not exist)";
|
||||
-r _ or return die "Invalid template '$file' requested (Permission denied)";
|
||||
|
||||
# Make data available.
|
||||
foreach my $key (keys % {$self->{data}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{data}->{$key};
|
||||
}
|
||||
|
||||
# Make cgi input available.
|
||||
foreach my $key (keys % {$self->{cgi}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{cgi}->{$key};
|
||||
}
|
||||
|
||||
# Make commands available.
|
||||
my $count = 0;
|
||||
if ($self->{commands}) { #activate or deactivate the commands
|
||||
foreach my $key (keys % {$self->{commands}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{commands}->{$key};
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
|
||||
$args->{show_all} = '1' if ($count == 0);
|
||||
$args->{status} ||= $self->{status};
|
||||
$args->{input} = $self->{input};
|
||||
$args->{http_ref} = $self->{http_ref};
|
||||
$args->{url_opts} = $self->{url_opts};
|
||||
$args->{work_path} = $self->{work_path} || $self->{cgi}->{work_path};
|
||||
$args->{template_root} = $self->{cfg}->{template_root};
|
||||
|
||||
$args->{root_dir} = $self->{cfg}->{root_dir};
|
||||
$args->{html_url} = $self->{cfg}->{html_root_url};
|
||||
$args->{root_url} = $self->{cfg}->{root_url};
|
||||
$args->{root_select} = $self->{cfg}->{root_select} if ($self->{cfg}->{root_select});
|
||||
$args->{session_id} = $self->{cfg}->{session_id} if ($self->{cfg}->{session_id});
|
||||
$args->{user_sessions} = $self->{cfg}->{user_sessions} if ($self->{cfg}->{user_sessions});
|
||||
$args->{username} = $self->{cfg}->{username} if ($self->{cfg}->{username});
|
||||
$args->{multi} = $self->{cfg}->{multi} if ($self->{cfg}->{multi});
|
||||
$args->{single} = $self->{cfg}->{single} if ($self->{cfg}->{single});
|
||||
|
||||
$args->{have_gzip} = $HAVE_GZIP;
|
||||
$args->{have_azip} = $HAVE_AZIP;
|
||||
$args->{srv_soft} = ($ENV{SERVER_SOFTWARE} =~ /Apache|Unix/)? 0 : 1 if ($ENV{SERVER_SOFTWARE});
|
||||
$args->{position} = $self->{in}->cookie('readme_position') if ($args->{readme});
|
||||
|
||||
$args->{scheme} = $self->{in}->cookie('scheme') || 'fileman';
|
||||
$args->{font} = $self->{in}->cookie('font') || "<font face='Verdana, Arial, Helvetica, sans-serif' size=2>";
|
||||
$args->{font} =~ s/[\'\"]/\'/g;
|
||||
|
||||
# Used for HTML editor
|
||||
my $brws = $self->get_browser();
|
||||
|
||||
# Export home for using in auto generate HTML.
|
||||
GT::Template->parse ("$template_path/$file", { %$args, %$brws }, { print => 1 });
|
||||
}
|
||||
|
||||
sub get_browser {
|
||||
my ($self, $verify) = @_;
|
||||
my ($version, %brws);
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i) {
|
||||
$version = $1;
|
||||
$brws{ie_version} = $version;
|
||||
}
|
||||
$brws{is_ie} = ($version and $version >= 5.5) ? 1 : 0;
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ m{Mozilla/(\d+\.\d+)\s+\([^)]*rv:(\d+\.\d+)\)}) {
|
||||
if ($1 >= 5.0) {
|
||||
$brws{is_mozilla} = 1;
|
||||
$brws{mozilla_version} = $2;
|
||||
}
|
||||
}
|
||||
if ( $verify ) {
|
||||
($brws{ie_version} >= 5.5 or $brws{mozilla_version} >= 1.4) ? return 1 : return 0;
|
||||
}
|
||||
else {
|
||||
return \%brws;
|
||||
}
|
||||
}
|
||||
|
||||
sub load_config {
|
||||
# --------------------------------------------------------------------
|
||||
# Load the config file into a hash.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $self->{cfg_path} || 'ConfigData.pm';
|
||||
my $cfg = do $file;
|
||||
if (ref $cfg ne 'HASH') {
|
||||
die "Invalid config file: $file. Got: '$cfg' instead of actual data. Error: $@ $!";
|
||||
}
|
||||
return $cfg;
|
||||
}
|
||||
|
||||
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 $in = new GT::CGI;
|
||||
print $in->header;
|
||||
|
||||
my $work_path = $in->param('work_path') || '';
|
||||
|
||||
print qq!
|
||||
<font face='Tahoma,Arial,Helvetica' size=2>A fatal error has occured:</font></p><blockquote><pre>$msg</pre></blockquote><p><font face='Tahoma,Arial,Helvetica' size=2>Please enable debugging in setup for more details.</font></p>\n
|
||||
!;
|
||||
if ($DEBUG) {
|
||||
print base_env();
|
||||
}
|
||||
}
|
||||
|
||||
sub base_env {
|
||||
# --------------------------------------------------------------------
|
||||
# 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('FileMan', 1, 1);
|
||||
$info .= "\n\n";
|
||||
|
||||
$info .= "<B>System Information</B>\n======================================\n";
|
||||
$info .= "Perl Version: $]\n";
|
||||
$info .= "FileMan Version: $FileMan::VERSION\n" if ($FileMan::VERSION);
|
||||
$info .= "Persistant Env: mod_perl (" . (MOD_PERL ? 1 : 0) . ") SpeedyCGI (" . (SPEEDY ? 1 : 0) . ")\n";
|
||||
$info .= "Mod Perl Version: " . MOD_PERL . "\n" if MOD_PERL;
|
||||
$info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
|
||||
$info .= "\$\@: $@\n" if ($@);
|
||||
$info .= "\n";
|
||||
|
||||
# Environment info.
|
||||
$info .= "<B>ENVIRONMENT</B>\n======================================\n";
|
||||
foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
|
||||
$info .= "</PRE>";
|
||||
return $info;
|
||||
}
|
||||
|
||||
sub js_quote_include {
|
||||
# --------------------------------------------------------------------
|
||||
# This uses GT::Template to parse the passed in argument. The results are
|
||||
# javascript escaped, and then returned.
|
||||
#
|
||||
my $file = shift;
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $in = new GT::CGI;
|
||||
my $css_file = $in->cookie('scheme') || 'fileman';
|
||||
my $color;
|
||||
CASE: {
|
||||
($css_file eq 'fileman') and $color = '#D6D6D6', last CASE;
|
||||
($css_file eq 'gt') and $color = '#d9e4f2', last CASE;
|
||||
($css_file eq 'maple') and $color = '#F0E8CE', last CASE;
|
||||
($css_file eq 'rainy') and $color = '#CFD8C2', last CASE;
|
||||
($css_file eq 'rose') and $color = '#DEC9CE', last CASE;
|
||||
}
|
||||
my $parsed = GT::Template->parse("$tags->{template_root}/common/$file",
|
||||
{
|
||||
html_url => $tags->{html_url},
|
||||
http_ref => $tags->{http_ref},
|
||||
filename => $tags->{filename},
|
||||
work_path => $tags->{work_path},
|
||||
scrollbar_arrow_color => 'black',
|
||||
scrollbar_base_color => $color,
|
||||
editor_base_color => $color,
|
||||
advanced_editor_background => 'white',
|
||||
advanced_editor_font => 'arial'
|
||||
});
|
||||
$parsed =~ s{([\\/'"<>])}{\\$1}g;
|
||||
$parsed =~ s/(?:\r\n|\r|\n)/\\n/g;
|
||||
return \$parsed;
|
||||
}
|
||||
|
||||
1;
|
||||
3115
site/glist/lib/GT/FileMan/Commands.pm
Normal file
3115
site/glist/lib/GT/FileMan/Commands.pm
Normal file
File diff suppressed because it is too large
Load Diff
442
site/glist/lib/GT/FileMan/Diff.pm
Normal file
442
site/glist/lib/GT/FileMan/Diff.pm
Normal file
@ -0,0 +1,442 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Diff.pm,v 1.9 2004/02/17 01:33:07 jagerman 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 GT::FileMan::Diff;
|
||||
# ==================================================================
|
||||
# This module is based off the example scripts distributed with Algorthim::Diff
|
||||
#
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION %HTML_ESCAPE);
|
||||
use GT::File::Diff;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
|
||||
%HTML_ESCAPE = (
|
||||
'&' => '&',
|
||||
'<' => '<',
|
||||
'>' => '>',
|
||||
'"' => '"'
|
||||
);
|
||||
|
||||
my $File_Length_Difference = 0;
|
||||
|
||||
sub diff {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes two filenames, or two array refs, and returns a text diff. See also
|
||||
# html_diff. Optionally takes an additional number - if provided, you'll get
|
||||
# a unified context diff with however many lines of context as you passed in for
|
||||
# this value, otherwise you'll get a boring old <, >-type diff.
|
||||
# Returns 1 if the first file couldn't be opened, 2 if the second couldn't be
|
||||
# opened, and a scalar reference containing the diff otherwise.
|
||||
#
|
||||
my ($file1, $file2, $context_lines) = @_;
|
||||
my ($f1_mod, $f2_mod, $filename1, $filename2);
|
||||
|
||||
if (!ref $file1) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, "<$file1" or return 1;
|
||||
chomp(my @f1 = <$fh>);
|
||||
$f1_mod = (stat $fh)[9];
|
||||
($filename1, $file1) = ($file1, \@f1);
|
||||
}
|
||||
if (!ref $file2) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, "<$file2" or return 2;
|
||||
chomp(my @f2 = <$fh>);
|
||||
$f2_mod = (stat $fh)[9];
|
||||
($filename2, $file2) = ($file2, \@f2);
|
||||
}
|
||||
|
||||
my $ret = "";
|
||||
my $diff = GT::File::Diff::diff($file1, $file2, \&_hash);
|
||||
return \($ret = "Files are identical") if not @$diff;
|
||||
|
||||
if ($context_lines and $f1_mod and $f2_mod) {
|
||||
$ret .= "--- $filename1\t" . gmtime($f1_mod) . " -0000\n";
|
||||
$ret .= "+++ $filename2\t" . gmtime($f2_mod) . " -0000\n";
|
||||
}
|
||||
|
||||
$File_Length_Difference = 0;
|
||||
|
||||
my ($hunk, $oldhunk);
|
||||
for my $piece (@$diff) {
|
||||
$hunk = GT::FileMan::Diff::Hunk->new($file1, $file2, $piece, $context_lines);
|
||||
next unless $oldhunk;
|
||||
|
||||
if ($context_lines and $hunk->does_overlap($oldhunk)) {
|
||||
$hunk->prepend_hunk($oldhunk);
|
||||
}
|
||||
else {
|
||||
$ret .= $oldhunk->output_diff($file1, $file2, $context_lines);
|
||||
}
|
||||
} continue { $oldhunk = $hunk }
|
||||
|
||||
$ret .= $oldhunk->output_diff($file1, $file2, $context_lines);
|
||||
\$ret;
|
||||
}
|
||||
|
||||
# This generates a unique key for the line; we simply take the line and convert
|
||||
# all multiple spaces into a single space to effectively perform a "diff -b".
|
||||
sub _hash {
|
||||
my $str = shift;
|
||||
$str =~ s/^\s+//;
|
||||
$str =~ s/\s+$//;
|
||||
$str =~ s/\s{2,}/ /g;
|
||||
$str;
|
||||
}
|
||||
|
||||
sub html_diff {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Works exactly as the above, but also HTML escapes and colorizes the diff.
|
||||
# The first two or three arguments are the same as above, and the last argument
|
||||
# is a hash ref of (ID => html_color) pairs. The ID's available, and defaults,
|
||||
# are as follows (scalar refs make the text also bold):
|
||||
# { file => \"#2e8b57", linenum => \"#a52a2a", sep => "#6a5acd", removed => "#6a5acd", added => "#008b8b" }
|
||||
# - file is used only in unified context diffs to show the filename & last modified time
|
||||
# - linenum is used to indicate the line numbers the change applies to
|
||||
# - sep is used only in non-unified diffs to separate the removed/added lines
|
||||
# - removed is the colour for removed lines
|
||||
# - added is the colour for added lines
|
||||
# The return is the same scalar reference or error number as that of diff(),
|
||||
# but formatted for HTML with escaped HTML where necessary and the whole thing
|
||||
# wrapped in <pre>...</pre>. Note that no checking or HTML escaping is
|
||||
# performed on the colors passed in; it is your responsibility to make sure the
|
||||
# values of the colors hash are safe.
|
||||
#
|
||||
my (@args) = @_;
|
||||
my %colors;
|
||||
%colors = %{pop @args} if ref $args[-1];
|
||||
|
||||
$colors{file} ||= \"#2e8b57";
|
||||
$colors{linenum} ||= \"#a52a2a";
|
||||
$colors{added} ||= "#008b8b";
|
||||
$colors{removed} ||= "#6a5acd";
|
||||
$colors{sep} ||= "#6a5acd";
|
||||
|
||||
for (keys %colors) {
|
||||
if (ref $colors{$_}) {
|
||||
$colors{$_} = qq|<font color="${$colors{$_}}"><b>|;
|
||||
$colors{"${_}_close"} = qq|</b></font>|;
|
||||
}
|
||||
else {
|
||||
$colors{$_} = qq|<font color="$colors{$_}">|;
|
||||
$colors{"${_}_close"} = qq|</font>|;
|
||||
}
|
||||
}
|
||||
|
||||
my $ret = diff(@args);
|
||||
return $ret unless ref $ret;
|
||||
|
||||
$$ret =~ s/(["&<>])/$HTML_ESCAPE{$1}/g;
|
||||
$$ret =~ s{^([^ ].*)}{
|
||||
my $line = $1;
|
||||
if ($line eq '---') {
|
||||
qq{$colors{sep}$line$colors{sep_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 3) eq '---' or substr($line, 0, 3) eq '+++') {
|
||||
qq{$colors{file}$line$colors{file_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 2) eq '@@' or $line =~ /^[0-9]/) {
|
||||
qq{$colors{linenum}$line$colors{linenum_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 1) eq '+' or substr($line, 0, 4) eq '>') {
|
||||
qq{$colors{added}$line$colors{added_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 1) eq '-' or substr($line, 0, 4) eq '<') {
|
||||
qq{$colors{removed}$line$colors{removed_close}}
|
||||
}
|
||||
else {
|
||||
# A mistake? We should never get here, but silently ignore if we do
|
||||
$line
|
||||
}
|
||||
}egm;
|
||||
|
||||
substr($$ret, 0, 0) = '<pre>';
|
||||
$$ret .= '</pre>';
|
||||
|
||||
$ret;
|
||||
}
|
||||
|
||||
|
||||
# Package Hunk. A Hunk is a group of Blocks which overlap because of the
|
||||
# context surrounding each block. (So if we're not using context, every
|
||||
# hunk will contain one block.)
|
||||
package GT::FileMan::Diff::Hunk;
|
||||
|
||||
sub new {
|
||||
# Arg1 is output from &LCS::diff (which corresponds to one Block)
|
||||
# Arg2 is the number of items (lines, e.g.,) of context around each block
|
||||
#
|
||||
# This subroutine changes $File_Length_Difference
|
||||
#
|
||||
# Fields in a Hunk:
|
||||
# blocks - a list of Block objects
|
||||
# start - index in file 1 where first block of the hunk starts
|
||||
# end - index in file 1 where last block of the hunk ends
|
||||
#
|
||||
# Variables:
|
||||
# before_diff - how much longer file 2 is than file 1 due to all hunks
|
||||
# until but NOT including this one
|
||||
# after_diff - difference due to all hunks including this one
|
||||
my ($class, $f1, $f2, $piece, $context_items) = @_;
|
||||
|
||||
my $block = new GT::FileMan::Diff::Block ($piece); # this modifies $FLD!
|
||||
|
||||
my $before_diff = $File_Length_Difference; # BEFORE this hunk
|
||||
my $after_diff = $before_diff + $block->{"length_diff"};
|
||||
$File_Length_Difference += $block->{"length_diff"};
|
||||
|
||||
# @remove_array and @insert_array hold the items to insert and remove
|
||||
# Save the start & beginning of each array. If the array doesn't exist
|
||||
# though (e.g., we're only adding items in this block), then figure
|
||||
# out the line number based on the line number of the other file and
|
||||
# the current difference in file lenghts
|
||||
my @remove_array = $block->remove;
|
||||
my @insert_array = $block->insert;
|
||||
my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
|
||||
$a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
|
||||
$a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
|
||||
$b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
|
||||
$b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;
|
||||
|
||||
$start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
|
||||
$end1 = $a2 == -1 ? $b2 - $after_diff : $a2;
|
||||
$start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
|
||||
$end2 = $b2 == -1 ? $a2 + $after_diff : $b2;
|
||||
|
||||
# At first, a hunk will have just one Block in it
|
||||
my $hunk = {
|
||||
"start1" => $start1,
|
||||
"start2" => $start2,
|
||||
"end1" => $end1,
|
||||
"end2" => $end2,
|
||||
"blocks" => [$block],
|
||||
"f1" => $f1,
|
||||
"f2" => $f2
|
||||
};
|
||||
bless $hunk, $class;
|
||||
|
||||
$hunk->flag_context($context_items);
|
||||
|
||||
return $hunk;
|
||||
}
|
||||
|
||||
# Change the "start" and "end" fields to note that context should be added
|
||||
# to this hunk
|
||||
sub flag_context {
|
||||
my ($hunk, $context_items) = @_;
|
||||
return unless $context_items; # no context
|
||||
|
||||
# add context before
|
||||
my $start1 = $hunk->{"start1"};
|
||||
my $num_added = $context_items > $start1 ? $start1 : $context_items;
|
||||
$hunk->{"start1"} -= $num_added;
|
||||
$hunk->{"start2"} -= $num_added;
|
||||
|
||||
# context after
|
||||
my $end1 = $hunk->{"end1"};
|
||||
$num_added = ($end1+$context_items > $#{$hunk->{f1}}) ?
|
||||
$#{$hunk->{f1}} - $end1 :
|
||||
$context_items;
|
||||
$hunk->{"end1"} += $num_added;
|
||||
$hunk->{"end2"} += $num_added;
|
||||
}
|
||||
|
||||
# Is there an overlap between hunk arg0 and old hunk arg1?
|
||||
# Note: if end of old hunk is one less than beginning of second, they overlap
|
||||
sub does_overlap {
|
||||
my ($hunk, $oldhunk) = @_;
|
||||
return "" unless $oldhunk; # first time through, $oldhunk is empty
|
||||
|
||||
# Do I actually need to test both?
|
||||
return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
|
||||
$hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
|
||||
}
|
||||
|
||||
# Prepend hunk arg1 to hunk arg0
|
||||
# Note that arg1 isn't updated! Only arg0 is.
|
||||
sub prepend_hunk {
|
||||
my ($hunk, $oldhunk) = @_;
|
||||
|
||||
$hunk->{"start1"} = $oldhunk->{"start1"};
|
||||
$hunk->{"start2"} = $oldhunk->{"start2"};
|
||||
|
||||
unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
|
||||
}
|
||||
|
||||
|
||||
# DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...
|
||||
sub output_diff {
|
||||
my $context_diff = $_[3];
|
||||
if ($context_diff) { return &output_unified_diff }
|
||||
else { return &output_boring_diff }
|
||||
}
|
||||
|
||||
sub output_unified_diff {
|
||||
my ($hunk, $fileref1, $fileref2) = @_;
|
||||
my @blocklist;
|
||||
my $ret = "";
|
||||
|
||||
# Calculate item number range.
|
||||
my $range1 = $hunk->unified_range(1);
|
||||
my $range2 = $hunk->unified_range(2);
|
||||
$ret .= "@@ -$range1 +$range2 @@\n";
|
||||
|
||||
# Outlist starts containing the hunk of file 1.
|
||||
# Removing an item just means putting a '-' in front of it.
|
||||
# Inserting an item requires getting it from file2 and splicing it in.
|
||||
# We splice in $num_added items. Remove blocks use $num_added because
|
||||
# splicing changed the length of outlist.
|
||||
# We remove $num_removed items. Insert blocks use $num_removed because
|
||||
# their item numbers---corresponding to positions in file *2*--- don't take
|
||||
# removed items into account.
|
||||
my $low = $hunk->{"start1"};
|
||||
my $hi = $hunk->{"end1"};
|
||||
my ($num_added, $num_removed) = (0,0);
|
||||
my @outlist = @$fileref1[$low..$hi];
|
||||
for (@outlist) { s/^/ / } # assume it's just context
|
||||
|
||||
foreach my $block (@{$hunk->{"blocks"}}) {
|
||||
foreach my $item ($block->remove) {
|
||||
my $op = $item->{"sign"}; # -
|
||||
my $offset = $item->{"item_no"} - $low + $num_added;
|
||||
$outlist[$offset] =~ s/^ /$op/;
|
||||
$num_removed++;
|
||||
}
|
||||
foreach my $item ($block->insert) {
|
||||
my $op = $item->{"sign"}; # +
|
||||
my $i = $item->{"item_no"};
|
||||
my $offset = $i - $hunk->{"start2"} + $num_removed;
|
||||
splice(@outlist,$offset,0,"$op$$fileref2[$i]");
|
||||
$num_added++;
|
||||
}
|
||||
}
|
||||
|
||||
for (@outlist) { $ret .= "$_\n" } # add \n's
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub output_boring_diff {
|
||||
# Note that an old diff can't have any context. Therefore, we know that
|
||||
# there's only one block in the hunk.
|
||||
my ($hunk, $fileref1, $fileref2) = @_;
|
||||
my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');
|
||||
|
||||
my $ret = '';
|
||||
my @blocklist = @{$hunk->{"blocks"}};
|
||||
warn ("Expecting one block in an old diff hunk!") if scalar @blocklist != 1;
|
||||
my $block = $blocklist[0];
|
||||
my $op = $block->op; # +, -, or !
|
||||
|
||||
# Calculate item number range.
|
||||
# old diff range is just like a context diff range, except the ranges
|
||||
# are on one line with the action between them.
|
||||
my $range1 = $hunk->context_range(1);
|
||||
my $range2 = $hunk->context_range(2);
|
||||
my $action = $op_hash{$op} || warn "unknown op $op";
|
||||
$ret .= "$range1$action$range2\n";
|
||||
|
||||
# If removing anything, just print out all the remove lines in the hunk
|
||||
# which is just all the remove lines in the block
|
||||
if (my @foo = $block->remove) {
|
||||
my @outlist = @$fileref1[$hunk->{"start1"}..$hunk->{"end1"}];
|
||||
map {$_ = "< $_\n"} @outlist; # all lines will be '< text\n'
|
||||
$ret .= join '', @outlist;
|
||||
}
|
||||
|
||||
$ret .= "---\n" if $op eq '!'; # only if inserting and removing
|
||||
if ($block->insert) {
|
||||
my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
|
||||
map {$_ = "> $_\n"} @outlist; # all lines will be '> text\n'
|
||||
$ret .= join "", @outlist;
|
||||
}
|
||||
}
|
||||
|
||||
sub context_range {
|
||||
# Generate a range of item numbers to print. Only print 1 number if the range
|
||||
# has only one item in it. Otherwise, it's 'start,end'
|
||||
my ($hunk, $flag) = @_;
|
||||
my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
|
||||
$start++; $end++; # index from 1, not zero
|
||||
my $range = ($start < $end) ? "$start,$end" : $end;
|
||||
return $range;
|
||||
}
|
||||
|
||||
sub unified_range {
|
||||
# Generate a range of item numbers to print for unified diff
|
||||
# Print number where block starts, followed by number of lines in the block
|
||||
# (don't print number of lines if it's 1)
|
||||
my ($hunk, $flag) = @_;
|
||||
my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
|
||||
$start++; $end++; # index from 1, not zero
|
||||
my $length = $end - $start + 1;
|
||||
my $first = $length < 2 ? $end : $start; # strange, but correct...
|
||||
my $range = $length== 1 ? $first : "$first,$length";
|
||||
return $range;
|
||||
}
|
||||
|
||||
package GT::FileMan::Diff::Block;
|
||||
# Package Block. A block is an operation removing, adding, or changing
|
||||
# a group of items. Basically, this is just a list of changes, where each
|
||||
# change adds or deletes a single item.
|
||||
# (Change could be a separate class, but it didn't seem worth it)
|
||||
|
||||
sub new {
|
||||
# Input is a chunk from &Algorithm::LCS::diff
|
||||
# Fields in a block:
|
||||
# length_diff - how much longer file 2 is than file 1 due to this block
|
||||
# Each change has:
|
||||
# sign - '+' for insert, '-' for remove
|
||||
# item_no - number of the item in the file (e.g., line number)
|
||||
# We don't bother storing the text of the item
|
||||
#
|
||||
my ($class,$chunk) = @_;
|
||||
my @changes = ();
|
||||
|
||||
# This just turns each change into a hash.
|
||||
foreach my $item (@$chunk) {
|
||||
my ($sign, $item_no, $text) = @$item;
|
||||
my $hashref = {"sign" => $sign, "item_no" => $item_no};
|
||||
push @changes, $hashref;
|
||||
}
|
||||
|
||||
my $block = { "changes" => \@changes };
|
||||
bless $block, $class;
|
||||
|
||||
$block->{"length_diff"} = $block->insert - $block->remove;
|
||||
return $block;
|
||||
}
|
||||
|
||||
|
||||
# LOW LEVEL FUNCTIONS
|
||||
sub op {
|
||||
# what kind of block is this?
|
||||
my $block = shift;
|
||||
my $insert = $block->insert;
|
||||
my $remove = $block->remove;
|
||||
|
||||
$remove && $insert and return '!';
|
||||
$remove and return '-';
|
||||
$insert and return '+';
|
||||
warn "unknown block type";
|
||||
return '^'; # context block
|
||||
}
|
||||
|
||||
# Returns a list of the changes in this block that remove items
|
||||
# (or the number of removals if called in scalar context)
|
||||
sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }
|
||||
|
||||
# Returns a list of the changes in this block that insert items
|
||||
sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }
|
||||
|
||||
1;
|
||||
520
site/glist/lib/GT/MD5.pm
Normal file
520
site/glist/lib/GT/MD5.pm
Normal file
@ -0,0 +1,520 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::MD5
|
||||
# Author: Scott Beck (see pod for details)
|
||||
# CVS Info :
|
||||
# $Id: MD5.pm,v 1.19 2004/11/17 01:23:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# See bottom for addition Copyrights.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: This is an implementation of the MD5 algorithm in perl.
|
||||
#
|
||||
|
||||
package GT::MD5;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORTER @EXPORT_OK $DATA);
|
||||
|
||||
@EXPORT_OK = qw(md5 md5_hex md5_base64);
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$DATA = <<'END_OF_CODE';
|
||||
use integer;
|
||||
|
||||
# I-Vektor
|
||||
sub A() { 0x67_45_23_01 }
|
||||
sub B() { 0xef_cd_ab_89 }
|
||||
sub C() { 0x98_ba_dc_fe }
|
||||
sub D() { 0x10_32_54_76 }
|
||||
|
||||
# for internal use
|
||||
sub MAX() { 0xFFFFFFFF }
|
||||
|
||||
@GT::MD5::DATA = split "\n", q|
|
||||
FF,$a,$b,$c,$d,$_[4],7,0xd76aa478,/* 1 */
|
||||
FF,$d,$a,$b,$c,$_[5],12,0xe8c7b756,/* 2 */
|
||||
FF,$c,$d,$a,$b,$_[6],17,0x242070db,/* 3 */
|
||||
FF,$b,$c,$d,$a,$_[7],22,0xc1bdceee,/* 4 */
|
||||
FF,$a,$b,$c,$d,$_[8],7,0xf57c0faf,/* 5 */
|
||||
FF,$d,$a,$b,$c,$_[9],12,0x4787c62a,/* 6 */
|
||||
FF,$c,$d,$a,$b,$_[10],17,0xa8304613,/* 7 */
|
||||
FF,$b,$c,$d,$a,$_[11],22,0xfd469501,/* 8 */
|
||||
FF,$a,$b,$c,$d,$_[12],7,0x698098d8,/* 9 */
|
||||
FF,$d,$a,$b,$c,$_[13],12,0x8b44f7af,/* 10 */
|
||||
FF,$c,$d,$a,$b,$_[14],17,0xffff5bb1,/* 11 */
|
||||
FF,$b,$c,$d,$a,$_[15],22,0x895cd7be,/* 12 */
|
||||
FF,$a,$b,$c,$d,$_[16],7,0x6b901122,/* 13 */
|
||||
FF,$d,$a,$b,$c,$_[17],12,0xfd987193,/* 14 */
|
||||
FF,$c,$d,$a,$b,$_[18],17,0xa679438e,/* 15 */
|
||||
FF,$b,$c,$d,$a,$_[19],22,0x49b40821,/* 16 */
|
||||
GG,$a,$b,$c,$d,$_[5],5,0xf61e2562,/* 17 */
|
||||
GG,$d,$a,$b,$c,$_[10],9,0xc040b340,/* 18 */
|
||||
GG,$c,$d,$a,$b,$_[15],14,0x265e5a51,/* 19 */
|
||||
GG,$b,$c,$d,$a,$_[4],20,0xe9b6c7aa,/* 20 */
|
||||
GG,$a,$b,$c,$d,$_[9],5,0xd62f105d,/* 21 */
|
||||
GG,$d,$a,$b,$c,$_[14],9,0x2441453,/* 22 */
|
||||
GG,$c,$d,$a,$b,$_[19],14,0xd8a1e681,/* 23 */
|
||||
GG,$b,$c,$d,$a,$_[8],20,0xe7d3fbc8,/* 24 */
|
||||
GG,$a,$b,$c,$d,$_[13],5,0x21e1cde6,/* 25 */
|
||||
GG,$d,$a,$b,$c,$_[18],9,0xc33707d6,/* 26 */
|
||||
GG,$c,$d,$a,$b,$_[7],14,0xf4d50d87,/* 27 */
|
||||
GG,$b,$c,$d,$a,$_[12],20,0x455a14ed,/* 28 */
|
||||
GG,$a,$b,$c,$d,$_[17],5,0xa9e3e905,/* 29 */
|
||||
GG,$d,$a,$b,$c,$_[6],9,0xfcefa3f8,/* 30 */
|
||||
GG,$c,$d,$a,$b,$_[11],14,0x676f02d9,/* 31 */
|
||||
GG,$b,$c,$d,$a,$_[16],20,0x8d2a4c8a,/* 32 */
|
||||
HH,$a,$b,$c,$d,$_[9],4,0xfffa3942,/* 33 */
|
||||
HH,$d,$a,$b,$c,$_[12],11,0x8771f681,/* 34 */
|
||||
HH,$c,$d,$a,$b,$_[15],16,0x6d9d6122,/* 35 */
|
||||
HH,$b,$c,$d,$a,$_[18],23,0xfde5380c,/* 36 */
|
||||
HH,$a,$b,$c,$d,$_[5],4,0xa4beea44,/* 37 */
|
||||
HH,$d,$a,$b,$c,$_[8],11,0x4bdecfa9,/* 38 */
|
||||
HH,$c,$d,$a,$b,$_[11],16,0xf6bb4b60,/* 39 */
|
||||
HH,$b,$c,$d,$a,$_[14],23,0xbebfbc70,/* 40 */
|
||||
HH,$a,$b,$c,$d,$_[17],4,0x289b7ec6,/* 41 */
|
||||
HH,$d,$a,$b,$c,$_[4],11,0xeaa127fa,/* 42 */
|
||||
HH,$c,$d,$a,$b,$_[7],16,0xd4ef3085,/* 43 */
|
||||
HH,$b,$c,$d,$a,$_[10],23,0x4881d05,/* 44 */
|
||||
HH,$a,$b,$c,$d,$_[13],4,0xd9d4d039,/* 45 */
|
||||
HH,$d,$a,$b,$c,$_[16],11,0xe6db99e5,/* 46 */
|
||||
HH,$c,$d,$a,$b,$_[19],16,0x1fa27cf8,/* 47 */
|
||||
HH,$b,$c,$d,$a,$_[6],23,0xc4ac5665,/* 48 */
|
||||
II,$a,$b,$c,$d,$_[4],6,0xf4292244,/* 49 */
|
||||
II,$d,$a,$b,$c,$_[11],10,0x432aff97,/* 50 */
|
||||
II,$c,$d,$a,$b,$_[18],15,0xab9423a7,/* 51 */
|
||||
II,$b,$c,$d,$a,$_[9],21,0xfc93a039,/* 52 */
|
||||
II,$a,$b,$c,$d,$_[16],6,0x655b59c3,/* 53 */
|
||||
II,$d,$a,$b,$c,$_[7],10,0x8f0ccc92,/* 54 */
|
||||
II,$c,$d,$a,$b,$_[14],15,0xffeff47d,/* 55 */
|
||||
II,$b,$c,$d,$a,$_[5],21,0x85845dd1,/* 56 */
|
||||
II,$a,$b,$c,$d,$_[12],6,0x6fa87e4f,/* 57 */
|
||||
II,$d,$a,$b,$c,$_[19],10,0xfe2ce6e0,/* 58 */
|
||||
II,$c,$d,$a,$b,$_[10],15,0xa3014314,/* 59 */
|
||||
II,$b,$c,$d,$a,$_[17],21,0x4e0811a1,/* 60 */
|
||||
II,$a,$b,$c,$d,$_[8],6,0xf7537e82,/* 61 */
|
||||
II,$d,$a,$b,$c,$_[15],10,0xbd3af235,/* 62 */
|
||||
II,$c,$d,$a,$b,$_[6],15,0x2ad7d2bb,/* 63 */
|
||||
II,$b,$c,$d,$a,$_[13],21,0xeb86d391,/* 64 */|;
|
||||
|
||||
|
||||
# padd a message to a multiple of 64
|
||||
sub padding {
|
||||
my $l = length (my $msg = shift() . chr(128));
|
||||
$msg .= "\0" x (($l%64<=56?56:120)-$l%64);
|
||||
$l = ($l-1)*8;
|
||||
$msg .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
|
||||
}
|
||||
|
||||
|
||||
sub rotate_left($$) {
|
||||
#$_[0] << $_[1] | $_[0] >> (32 - $_[1]);
|
||||
#my $right = $_[0] >> (32 - $_[1]);
|
||||
#my $rmask = (1 << $_[1]) - 1;
|
||||
($_[0] << $_[1]) | (( $_[0] >> (32 - $_[1]) ) & ((1 << $_[1]) - 1));
|
||||
#$_[0] << $_[1] | (($_[0]>> (32 - $_[1])) & (1 << (32 - $_[1])) - 1);
|
||||
}
|
||||
|
||||
sub gen_code {
|
||||
# Discard upper 32 bits on 64 bit archs.
|
||||
my $MSK = ((1 << 16) << 16) ? ' & ' . MAX : '';
|
||||
# FF => "X0=rotate_left(((X1&X2)|(~X1&X3))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
# GG => "X0=rotate_left(((X1&X3)|(X2&(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
my %f = (
|
||||
FF => "X0=rotate_left((X3^(X1&(X2^X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
GG => "X0=rotate_left((X2^(X3&(X1^X2)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
HH => "X0=rotate_left((X1^X2^X3)+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
II => "X0=rotate_left((X2^(X1|(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
);
|
||||
#unless ( (1 << 16) << 16) { %f = %{$CODES{'32bit'}} }
|
||||
#else { %f = %{$CODES{'64bit'}} }
|
||||
|
||||
my %s = ( # shift lengths
|
||||
S11 => 7, S12 => 12, S13 => 17, S14 => 22, S21 => 5, S22 => 9, S23 => 14,
|
||||
S24 => 20, S31 => 4, S32 => 11, S33 => 16, S34 => 23, S41 => 6, S42 => 10,
|
||||
S43 => 15, S44 => 21
|
||||
);
|
||||
|
||||
my $insert = "\n";
|
||||
# while(<DATA>) {
|
||||
for (@GT::MD5::DATA) {
|
||||
# chomp;
|
||||
next unless /^[FGHI]/;
|
||||
my ($func,@x) = split /,/;
|
||||
my $c = $f{$func};
|
||||
$c =~ s/X(\d)/$x[$1]/g;
|
||||
$c =~ s/(S\d{2})/$s{$1}/;
|
||||
$c =~ s/^(.*)=rotate_left\((.*),(.*)\)\+(.*)$//;
|
||||
|
||||
my $su = 32 - $3;
|
||||
my $sh = (1 << $3) - 1;
|
||||
|
||||
$c = "$1=(((\$r=$2)<<$3)|((\$r>>$su)&$sh))+$4";
|
||||
|
||||
#my $rotate = "(($2 << $3) || (($2 >> (32 - $3)) & (1 << $2) - 1)))";
|
||||
# $c = "\$r = $2;
|
||||
# $1 = ((\$r << $3) | ((\$r >> (32 - $3)) & ((1 << $3) - 1))) + $4";
|
||||
$insert .= "\t$c\n";
|
||||
}
|
||||
# close DATA;
|
||||
|
||||
my $dump = '
|
||||
sub round {
|
||||
my ($a,$b,$c,$d) = @_[0 .. 3];
|
||||
my $r;' . $insert . '
|
||||
$_[0]+$a' . $MSK . ', $_[1]+$b ' . $MSK .
|
||||
', $_[2]+$c' . $MSK . ', $_[3]+$d' . $MSK . ';
|
||||
}';
|
||||
eval $dump;
|
||||
# print "$dump\n";
|
||||
# exit 0;
|
||||
}
|
||||
|
||||
gen_code();
|
||||
|
||||
#########################################
|
||||
# Private output converter functions:
|
||||
sub _encode_hex { unpack 'H*', $_[0] }
|
||||
sub _encode_base64 {
|
||||
my $res;
|
||||
while ($_[0] =~ /(.{1,45})/gs) {
|
||||
$res .= substr pack('u', $1), 1;
|
||||
chop $res;
|
||||
}
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;#`
|
||||
chop $res; chop $res;
|
||||
$res
|
||||
}
|
||||
|
||||
#########################################
|
||||
# OOP interface:
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref $proto || $proto;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
$self->reset();
|
||||
$self
|
||||
}
|
||||
|
||||
sub reset {
|
||||
my $self = shift;
|
||||
delete $self->{_data};
|
||||
$self->{_state} = [A,B,C,D];
|
||||
$self->{_length} = 0;
|
||||
$self
|
||||
}
|
||||
|
||||
sub add {
|
||||
my $self = shift;
|
||||
$self->{_data} .= join '', @_ if @_;
|
||||
my ($i,$c);
|
||||
for $i (0 .. (length $self->{_data})/64-1) {
|
||||
my @X = unpack 'V16', substr $self->{_data}, $i*64, 64;
|
||||
@{$self->{_state}} = round(@{$self->{_state}},@X);
|
||||
++$c;
|
||||
}
|
||||
if ($c) {
|
||||
substr ($self->{_data}, 0, $c*64) = '';
|
||||
$self->{_length} += $c*64;
|
||||
}
|
||||
$self
|
||||
}
|
||||
|
||||
sub finalize {
|
||||
my $self = shift;
|
||||
$self->{_data} .= chr(128);
|
||||
my $l = $self->{_length} + length $self->{_data};
|
||||
$self->{_data} .= "\0" x (($l%64<=56?56:120)-$l%64);
|
||||
$l = ($l-1)*8;
|
||||
$self->{_data} .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
|
||||
$self->add();
|
||||
$self
|
||||
}
|
||||
|
||||
sub addfile {
|
||||
my ($self,$fh) = @_;
|
||||
if (!ref($fh) && ref(\$fh) ne "GLOB") {
|
||||
require Symbol;
|
||||
$fh = Symbol::qualify($fh, scalar caller);
|
||||
}
|
||||
# $self->{_data} .= do{local$/;<$fh>};
|
||||
my $read = 0;
|
||||
my $buffer = '';
|
||||
$self->add($buffer) while $read = read $fh, $buffer, 8192;
|
||||
die "GT::MD5 read failed: $!" unless defined $read;
|
||||
$self
|
||||
}
|
||||
|
||||
sub add_bits {
|
||||
my $self = shift;
|
||||
return $self->add( pack 'B*', shift ) if @_ == 1;
|
||||
my ($b,$n) = @_;
|
||||
die "GT::MD5 Invalid number of bits\n" if $n%8;
|
||||
$self->add( substr $b, 0, $n/8 )
|
||||
}
|
||||
|
||||
sub digest {
|
||||
my $self = shift;
|
||||
$self->finalize();
|
||||
my $res = pack 'V4', @{$self->{_state}};
|
||||
$self->reset();
|
||||
$res
|
||||
}
|
||||
|
||||
sub hexdigest {
|
||||
_encode_hex($_[0]->digest)
|
||||
}
|
||||
|
||||
sub b64digest {
|
||||
_encode_base64($_[0]->digest)
|
||||
}
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
my $clone = {
|
||||
_state => [@{$self->{_state}}],
|
||||
_length => $self->{_length},
|
||||
_data => $self->{_data}
|
||||
};
|
||||
bless $clone, ref $self || $self;
|
||||
}
|
||||
|
||||
#########################################
|
||||
# Procedural interface:
|
||||
sub md5 {
|
||||
my $message = padding(join'',@_);
|
||||
my ($a,$b,$c,$d) = (A,B,C,D);
|
||||
my $i;
|
||||
for $i (0 .. (length $message)/64-1) {
|
||||
my @X = unpack 'V16', substr $message,$i*64,64;
|
||||
($a,$b,$c,$d) = round($a,$b,$c,$d,@X);
|
||||
}
|
||||
pack 'V4',$a,$b,$c,$d;
|
||||
}
|
||||
sub md5_hex { _encode_hex &md5 }
|
||||
sub md5_base64 { _encode_base64 &md5 }
|
||||
END_OF_CODE
|
||||
|
||||
# Load either Digest::MD5 or GT::MD5 functions.
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
require Digest::MD5;
|
||||
foreach (@EXPORT_OK) { delete $GT::MD5::{$_}; } # Do not remove.
|
||||
import Digest::MD5 (@EXPORT_OK);
|
||||
*GT::MD5::md5_hex = sub { &Digest::MD5::md5_hex };
|
||||
*GT::MD5::md5 = sub { &Digest::MD5::md5 };
|
||||
*GT::MD5::md5_base64 = sub { &Digest::MD5::md5_base64 };
|
||||
@ISA = 'Digest::MD5';
|
||||
1;
|
||||
}
|
||||
or do {
|
||||
local $@;
|
||||
eval $DATA;
|
||||
$@ and die "GT::MD5 => can't compile: $@";
|
||||
};
|
||||
|
||||
require Exporter;
|
||||
import Exporter;
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::MD5 - Perl implementation of Ron Rivests MD5 Algorithm
|
||||
|
||||
=head1 DISCLAIMER
|
||||
|
||||
Majority of this module's code is borrowed from Digest::Perl::MD5 (Version 1.8).
|
||||
|
||||
This is B<not> an interface (like C<Digest::MD5>) but a Perl implementation of MD5.
|
||||
It is written in perl only and because of this it is slow but it works without C-Code.
|
||||
You should use C<Digest::MD5> instead of this module if it is available.
|
||||
This module is only usefull for
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
computers where you cannot install C<Digest::MD5> (e.g. lack of a C-Compiler)
|
||||
|
||||
=item
|
||||
|
||||
encrypting only small amounts of data (less than one million bytes). I use it to
|
||||
hash passwords.
|
||||
|
||||
=item
|
||||
|
||||
educational purposes
|
||||
|
||||
=back
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Functional style
|
||||
use Digest::MD5 qw(md5 md5_hex md5_base64);
|
||||
|
||||
$hash = md5 $data;
|
||||
$hash = md5_hex $data;
|
||||
$hash = md5_base64 $data;
|
||||
|
||||
|
||||
# OO style
|
||||
use Digest::MD5;
|
||||
|
||||
$ctx = Digest::MD5->new;
|
||||
|
||||
$ctx->add($data);
|
||||
$ctx->addfile(*FILE);
|
||||
|
||||
$digest = $ctx->digest;
|
||||
$digest = $ctx->hexdigest;
|
||||
$digest = $ctx->b64digest;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This modules has the same interface as the much faster C<Digest::MD5>. So you can
|
||||
easily exchange them, e.g.
|
||||
|
||||
BEGIN {
|
||||
eval {
|
||||
require Digest::MD5;
|
||||
import Digest::MD5 'md5_hex'
|
||||
};
|
||||
if ($@) { # ups, no Digest::MD5
|
||||
require Digest::Perl::MD5;
|
||||
import Digest::Perl::MD5 'md5_hex'
|
||||
}
|
||||
}
|
||||
|
||||
If the C<Digest::MD5> module is available it is used and if not you take
|
||||
C<Digest::Perl::MD5>.
|
||||
|
||||
You can also install the Perl part of Digest::MD5 together with Digest::Perl::MD5
|
||||
and use Digest::MD5 as normal, it falls back to Digest::Perl::MD5 if it
|
||||
cannot load its object files.
|
||||
|
||||
For a detailed Documentation see the C<Digest::MD5> module.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
The simplest way to use this library is to import the md5_hex()
|
||||
function (or one of its cousins):
|
||||
|
||||
use Digest::Perl::MD5 'md5_hex';
|
||||
print 'Digest is ', md5_hex('foobarbaz'), "\n";
|
||||
|
||||
The above example would print out the message
|
||||
|
||||
Digest is 6df23dc03f9b54cc38a0fc1483df6e21
|
||||
|
||||
provided that the implementation is working correctly. The same
|
||||
checksum can also be calculated in OO style:
|
||||
|
||||
use Digest::MD5;
|
||||
|
||||
$md5 = Digest::MD5->new;
|
||||
$md5->add('foo', 'bar');
|
||||
$md5->add('baz');
|
||||
$digest = $md5->hexdigest;
|
||||
|
||||
print "Digest is $digest\n";
|
||||
|
||||
The digest methods are destructive. That means you can only call them
|
||||
once and the $md5 objects is reset after use. You can make a copy with clone:
|
||||
|
||||
$md5->clone->hexdigest
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
This implementation of the MD5 algorithm has some limitations:
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
It's slow, very slow. I've done my very best but Digest::MD5 is still about 100 times faster.
|
||||
You can only encrypt Data up to one million bytes in an acceptable time. But it's very usefull
|
||||
for encrypting small amounts of data like passwords.
|
||||
|
||||
=item
|
||||
|
||||
You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. But You should
|
||||
use C<Digest::MD5> for those amounts of data anyway.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Digest::MD5>
|
||||
|
||||
L<md5(1)>
|
||||
|
||||
RFC 1321
|
||||
|
||||
tools/md5: a small BSD compatible md5 tool written in pure perl.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
Copyright 2000 Christian Lackas, Imperia Software Solutions
|
||||
Copyright 1998-1999 Gisle Aas.
|
||||
Copyright 1995-1996 Neil Winton.
|
||||
Copyright 1991-1992 RSA Data Security, Inc.
|
||||
|
||||
The MD5 algorithm is defined in RFC 1321. The basic C code
|
||||
implementing the algorithm is derived from that in the RFC and is
|
||||
covered by the following copyright:
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
Copyright (C) 1991-1992, RSA Data Security, Inc. Created 1991. All
|
||||
rights reserved.
|
||||
|
||||
License to copy and use this software is granted provided that it
|
||||
is identified as the "RSA Data Security, Inc. MD5 Message-Digest
|
||||
Algorithm" in all material mentioning or referencing this software
|
||||
or this function.
|
||||
|
||||
License is also granted to make and use derivative works provided
|
||||
that such works are identified as "derived from the RSA Data
|
||||
Security, Inc. MD5 Message-Digest Algorithm" in all material
|
||||
mentioning or referencing the derived work.
|
||||
|
||||
RSA Data Security, Inc. makes no representations concerning either
|
||||
the merchantability of this software or the suitability of this
|
||||
software for any particular purpose. It is provided "as is"
|
||||
without express or implied warranty of any kind.
|
||||
|
||||
These notices must be retained in any copies of any part of this
|
||||
documentation and/or software.
|
||||
|
||||
=back
|
||||
|
||||
This copyright does not prohibit distribution of any version of Perl
|
||||
containing this extension under the terms of the GNU or Artistic
|
||||
licenses.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
The original MD5 interface was written by Neil Winton
|
||||
(<N.Winton (at) axion.bt.co.uk>).
|
||||
|
||||
C<Digest::MD5> was made by Gisle Aas <gisle (at) aas.no> (I took his Interface
|
||||
and part of the documentation).
|
||||
|
||||
Thanks to Guido Flohr for his 'use integer'-hint.
|
||||
|
||||
This release was made by Christian Lackas <delta (at) lackas.net>.
|
||||
|
||||
=cut
|
||||
175
site/glist/lib/GT/MD5/Crypt.pm
Normal file
175
site/glist/lib/GT/MD5/Crypt.pm
Normal file
@ -0,0 +1,175 @@
|
||||
# GT::MD5::Crypt - adapted from CPAN Crypt::PasswdMD5 for use in the
|
||||
# Gossamer Thread module library. gt_md5_crypt was added which uses
|
||||
# "$GT$" as the magic string instead of the unix "$1$" or apache "$apr1$"
|
||||
#
|
||||
# Crypt::PasswdMD5: Module to provide an interoperable crypt()
|
||||
# function for modern Unix O/S. This is based on the code for
|
||||
#
|
||||
# /usr/src/libcrypt/crypt.c
|
||||
#
|
||||
# on a FreeBSD 2.2.5-RELEASE system, which included the following
|
||||
# notice.
|
||||
#
|
||||
# ----------------------------------------------------------------------------
|
||||
# "THE BEER-WARE LICENSE" (Revision 42):
|
||||
# <phk@login.dknet.dk> wrote this file. As long as you retain this notice you
|
||||
# can do whatever you want with this stuff. If we meet some day, and you think
|
||||
# this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp
|
||||
# ----------------------------------------------------------------------------
|
||||
#
|
||||
# 19980710 lem@cantv.net: Initial release
|
||||
# 19990402 bryan@eai.com: Added apache_md5_crypt to create a valid hash
|
||||
# for use in .htpasswd files
|
||||
# 20001006 wrowe@lnd.com: Requested apache_md5_crypt to be
|
||||
# exported by default.
|
||||
#
|
||||
################
|
||||
|
||||
package GT::MD5::Crypt;
|
||||
$VERSION='1.1';
|
||||
require 5.000;
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(unix_md5_crypt apache_md5_crypt gt_md5_crypt);
|
||||
|
||||
|
||||
$Magic = '$1$'; # Magic string
|
||||
$itoa64 = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
|
||||
|
||||
local $^W;
|
||||
|
||||
use GT::MD5;
|
||||
|
||||
sub to64 {
|
||||
my ($v, $n) = @_;
|
||||
my $ret = '';
|
||||
while (--$n >= 0) {
|
||||
$ret .= substr($itoa64, $v & 0x3f, 1);
|
||||
$v >>= 6;
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub apache_md5_crypt {
|
||||
# change the Magic string to match the one used by Apache
|
||||
local $Magic = '$apr1$';
|
||||
|
||||
unix_md5_crypt(@_);
|
||||
}
|
||||
|
||||
sub gt_md5_crypt {
|
||||
# change the Magic string to put our signature in the password
|
||||
local $Magic = '$GT$';
|
||||
|
||||
unix_md5_crypt(@_);
|
||||
}
|
||||
|
||||
sub unix_md5_crypt {
|
||||
my($pw, $salt) = @_;
|
||||
my $passwd;
|
||||
|
||||
$salt =~ s/^\Q$Magic//; # Take care of the magic string if
|
||||
# if present.
|
||||
|
||||
$salt =~ s/^(.*)\$.*$/$1/; # Salt can have up to 8 chars...
|
||||
$salt = substr($salt, 0, 8);
|
||||
|
||||
$ctx = new GT::MD5; # Here we start the calculation
|
||||
$ctx->add($pw); # Original password...
|
||||
$ctx->add($Magic); # ...our magic string...
|
||||
$ctx->add($salt); # ...the salt...
|
||||
|
||||
my ($final) = new GT::MD5;
|
||||
$final->add($pw);
|
||||
$final->add($salt);
|
||||
$final->add($pw);
|
||||
$final = $final->digest;
|
||||
|
||||
for ($pl = length($pw); $pl > 0; $pl -= 16) {
|
||||
$ctx->add(substr($final, 0, $pl > 16 ? 16 : $pl));
|
||||
}
|
||||
|
||||
# Now the 'weird' xform
|
||||
|
||||
for ($i = length($pw); $i; $i >>= 1) {
|
||||
if ($i & 1) { $ctx->add(pack("C", 0)); }
|
||||
# This comes from the original version,
|
||||
# where a memset() is done to $final
|
||||
# before this loop.
|
||||
else { $ctx->add(substr($pw, 0, 1)); }
|
||||
}
|
||||
|
||||
$final = $ctx->digest;
|
||||
# The following is supposed to make
|
||||
# things run slower. In perl, perhaps
|
||||
# it'll be *really* slow!
|
||||
|
||||
for ($i = 0; $i < 1000; $i++) {
|
||||
$ctx1 = new GT::MD5;
|
||||
if ($i & 1) { $ctx1->add($pw); }
|
||||
else { $ctx1->add(substr($final, 0, 16)); }
|
||||
if ($i % 3) { $ctx1->add($salt); }
|
||||
if ($i % 7) { $ctx1->add($pw); }
|
||||
if ($i & 1) { $ctx1->add(substr($final, 0, 16)); }
|
||||
else { $ctx1->add($pw); }
|
||||
$final = $ctx1->digest;
|
||||
}
|
||||
|
||||
# Final xform
|
||||
|
||||
$passwd = '';
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 0, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 6, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 12, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 1, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 7, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 13, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 2, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 8, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 14, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 3, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 9, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 15, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 4, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 10, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 5, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", substr($final, 11, 1))), 2);
|
||||
|
||||
$final = '';
|
||||
$Magic . $salt . '$' . $passwd;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
unix_md5_crypt - Provides interoperable MD5-based crypt() function
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::MD5::Crypt;
|
||||
|
||||
$cryptedpassword = unix_md5_crypt($password, $salt);
|
||||
|
||||
$valid = $cryptedpassword eq unix_md5_crypt($password, $cryptedpassword);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
the C<unix_md5_crypt()> provides a crypt()-compatible interface to the
|
||||
rather new MD5-based crypt() function found in modern operating systems.
|
||||
It's based on the implementation found on FreeBSD 2.2.[56]-RELEASE and
|
||||
contains the following license in it:
|
||||
|
||||
"THE BEER-WARE LICENSE" (Revision 42):
|
||||
<phk@login.dknet.dk> wrote this file. As long as you retain this notice you
|
||||
can do whatever you want with this stuff. If we meet some day, and you think
|
||||
this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp
|
||||
|
||||
C<apache_md5_crypt()> provides a function compatible with Apache's
|
||||
C<.htpasswd> files. This was contributed by Bryan Hart <bryan@eai.com>.
|
||||
As suggested by William A. Rowe, Jr. <wrowe@lnd.com>, it is
|
||||
exported by default.
|
||||
|
||||
=cut
|
||||
425
site/glist/lib/GT/MIMETypes.pm
Normal file
425
site/glist/lib/GT/MIMETypes.pm
Normal file
@ -0,0 +1,425 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::MIMETypes
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: MIMETypes.pm,v 1.24 2005/04/02 08:08:46 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Provides methods to guess mime types.
|
||||
#
|
||||
|
||||
package GT::MIMETypes;
|
||||
# ===================================================================
|
||||
use strict;
|
||||
use vars qw/%CONTENT_EXT %MIME_EXT %MIME_TYPE/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$COMPILE{guess_type} = __LINE__ . <<'END_OF_SUB';
|
||||
sub guess_type {
|
||||
# -------------------------------------------------------------------
|
||||
# Makes it's best guess based on input. Returns application/octet-stream
|
||||
# on failure to guess.
|
||||
# Possible arguments
|
||||
#{
|
||||
# filename => name of the file
|
||||
# filepath => full path to the file
|
||||
#}
|
||||
# No arguments are required but you will get application/octet-stream
|
||||
# with no arguments.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $msg = shift;
|
||||
|
||||
if (!ref $msg) {
|
||||
defined(%CONTENT_EXT) or content_ext();
|
||||
if ($msg =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
|
||||
return $CONTENT_EXT{lc $1};
|
||||
}
|
||||
else {
|
||||
return 'application/octet-stream';
|
||||
}
|
||||
}
|
||||
|
||||
# If we have a filename with an extension use that
|
||||
if ($msg->{filename} or $msg->{filepath}) {
|
||||
my $f;
|
||||
if ($msg->{filename}) {
|
||||
$f = $msg->{filename};
|
||||
}
|
||||
else {
|
||||
$f = $msg->{filepath};
|
||||
}
|
||||
defined(%CONTENT_EXT) or content_ext();
|
||||
if ($f =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
|
||||
return $CONTENT_EXT{lc $1};
|
||||
}
|
||||
}
|
||||
return 'application/octet-stream';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{guess_image} = __LINE__ . <<'END_OF_SUB';
|
||||
sub guess_image {
|
||||
# -------------------------------------------------------------------
|
||||
# Makes it's best guess based on input. Returns unknown.gif
|
||||
# on failure to guess.
|
||||
# Possible arguments
|
||||
#{
|
||||
# filename => name of the file
|
||||
# filepath => full path to the file
|
||||
# type => mime type
|
||||
#}
|
||||
# No arguments are required but you will get unknown.gif
|
||||
# with no arguments.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $msg = shift;
|
||||
my $image;
|
||||
|
||||
if (!ref $msg) {
|
||||
if ($msg =~ /\.([^.]+)$/) {
|
||||
defined(%MIME_EXT) or mime_ext();
|
||||
return $MIME_EXT{lc $1} || 'unknown.gif';
|
||||
}
|
||||
else {
|
||||
return 'unknown.gif';
|
||||
}
|
||||
}
|
||||
if ($msg->{filepath} and -d $msg->{filepath}) {
|
||||
return 'folder.gif';
|
||||
}
|
||||
|
||||
# If we have a filename with an extension use that
|
||||
my $f;
|
||||
if ($msg->{filename} or $msg->{filepath}) {
|
||||
if ($msg->{filename}) {
|
||||
$f = $msg->{filename};
|
||||
}
|
||||
else {
|
||||
$f = $msg->{filepath};
|
||||
}
|
||||
defined(%MIME_EXT) or mime_ext();
|
||||
if ($f =~ /\.([^.]+)$/ and exists $MIME_EXT{lc $1}) {
|
||||
return $MIME_EXT{lc $1};
|
||||
}
|
||||
}
|
||||
|
||||
# If a content type was passed in see if we know anything about it
|
||||
defined(%MIME_TYPE) or mime_type();
|
||||
if (exists $MIME_TYPE{$msg->{type} || $msg->{mime_type}}) {
|
||||
return $MIME_TYPE{$msg->{type} || $msg->{mime_type}};
|
||||
}
|
||||
|
||||
# No luck so far, resort to other means
|
||||
elsif ($msg->{filepath} and -B $msg->{filepath}) {
|
||||
return 'binary.gif';
|
||||
}
|
||||
elsif ($f and lc($f) =~ /readme/) {
|
||||
return 'readme.gif';
|
||||
}
|
||||
elsif ($msg->{filepath} and -T _) {
|
||||
return 'txt.gif';
|
||||
}
|
||||
|
||||
# Oops nothing
|
||||
return 'unknown.gif';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{mime_ext} = __LINE__ . <<'END_OF_SUB';
|
||||
sub mime_ext {
|
||||
# -------------------------------------------------------------------
|
||||
# Map file extension to image file
|
||||
#
|
||||
%MIME_EXT = (
|
||||
css => 'html.gif',
|
||||
htm => 'html.gif',
|
||||
html => 'html.gif',
|
||||
shtm => 'html.gif',
|
||||
shtml => 'html.gif',
|
||||
c => 'source.gif',
|
||||
cc => 'source.gif',
|
||||
'c++' => 'source.gif',
|
||||
cpp => 'source.gif',
|
||||
h => 'source.gif',
|
||||
pl => 'source.gif',
|
||||
pm => 'source.gif',
|
||||
cgi => 'source.gif',
|
||||
txt => 'txt.gif',
|
||||
text => 'txt.gif',
|
||||
eml => 'email.gif',
|
||||
email => 'email.gif',
|
||||
mime => 'email.gif',
|
||||
java => 'source.gif',
|
||||
el => 'source.gif',
|
||||
pdf => 'pdf.gif',
|
||||
dvi => 'dvi.gif',
|
||||
eds => 'postscript.gif',
|
||||
ai => 'postscript.gif',
|
||||
ps => 'postscript.gif',
|
||||
tex => 'tex.gif',
|
||||
texinfo => 'tex.gif',
|
||||
tar => 'tar.gif',
|
||||
ustar => 'tar.gif',
|
||||
tgz => 'tgz.gif',
|
||||
gz => 'tgz.gif',
|
||||
snd => 'sound.gif',
|
||||
au => 'sound.gif',
|
||||
aifc => 'sound.gif',
|
||||
aif => 'sound.gif',
|
||||
aiff => 'sound.gif',
|
||||
wav => 'sound.gif',
|
||||
mp3 => 'sound.gif',
|
||||
bmp => 'image.gif',
|
||||
gif => 'image.gif',
|
||||
ief => 'image.gif',
|
||||
jfif => 'image.gif',
|
||||
'jfif-tbnl' => 'image.gif',
|
||||
jpe => 'image.gif',
|
||||
jpg => 'image.gif',
|
||||
jpeg => 'image.gif',
|
||||
tif => 'image.gif',
|
||||
tiff => 'image.gif',
|
||||
fpx => 'image.gif',
|
||||
fpix => 'image.gif',
|
||||
ras => 'image.gif',
|
||||
pnm => 'image.gif',
|
||||
pbn => 'image.gif',
|
||||
pgm => 'image.gif',
|
||||
ppm => 'image.gif',
|
||||
rgb => 'image.gif',
|
||||
xbm => 'image.gif',
|
||||
xpm => 'image.gif',
|
||||
xwd => 'image.gif',
|
||||
png => 'image.gif',
|
||||
mpg => 'video.gif',
|
||||
mpe => 'video.gif',
|
||||
mpeg => 'video.gif',
|
||||
mov => 'video.gif',
|
||||
qt => 'video.gif',
|
||||
avi => 'video.gif',
|
||||
asf => 'video.gif',
|
||||
movie => 'video.gif',
|
||||
mv => 'video.gif',
|
||||
wmv => 'wvideo.gif',
|
||||
wma => 'wvideo.gif',
|
||||
sh => 'shellscript.gif',
|
||||
rpm => 'rpm.gif',
|
||||
ttf => 'font_true.gif',
|
||||
doc => 'doc.gif',
|
||||
xls => 'excel.gif',
|
||||
ppt => 'ppt.gif',
|
||||
zip => 'zip.gif'
|
||||
) unless keys %MIME_EXT;
|
||||
|
||||
%MIME_EXT;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{content_ext} = __LINE__ . <<'END_OF_SUB';
|
||||
sub content_ext {
|
||||
# -------------------------------------------------------------------
|
||||
# To guess the content-type for files by extension
|
||||
#
|
||||
%CONTENT_EXT = (
|
||||
doc => 'application/msword',
|
||||
ppt => 'application/mspowerpoint',
|
||||
xls => 'application/msexcel',
|
||||
oda => 'application/oda',
|
||||
pdf => 'application/pdf',
|
||||
eds => 'application/postscript',
|
||||
ai => 'application/postscript',
|
||||
ps => 'application/postscript',
|
||||
rtf => 'application/rtf',
|
||||
dvi => 'application/x-dvi',
|
||||
hdf => 'application/x-hdf',
|
||||
latex => 'application/x-latex',
|
||||
nc => 'application/x-netcdf',
|
||||
cdf => 'application/x-netcdf',
|
||||
tex => 'application/x-tex',
|
||||
texinfo => 'application/x-texinfo',
|
||||
texi => 'application/x-texinfo',
|
||||
t => 'application/x-troff',
|
||||
tr => 'application/x-troff',
|
||||
roff => 'application/x-troff',
|
||||
man => 'application/x-troff-man',
|
||||
me => 'application/x-troff-me',
|
||||
ms => 'application/x-troff-ms',
|
||||
src => 'application/x-wais-source',
|
||||
wsrc => 'application/x-wais-source',
|
||||
zip => 'application/zip',
|
||||
bcpio => 'application/x-bcpio',
|
||||
cpio => 'application/x-cpio',
|
||||
gtar => 'application/x-gtar',
|
||||
sh => 'application/x-shar',
|
||||
shar => 'application/x-shar',
|
||||
sv4cpio => 'application/x-sv4cpio',
|
||||
sv4crc => 'application/x-sv4crc',
|
||||
tar => 'application/x-tar',
|
||||
ustar => 'application/x-ustar',
|
||||
snd => 'audio/basic',
|
||||
au => 'audio/basic',
|
||||
aifc => 'audio/x-aiff',
|
||||
aif => 'audio/x-aiff',
|
||||
aiff => 'audio/x-aiff',
|
||||
wav => 'audio/x-wav',
|
||||
mp3 => 'audio/mpeg',
|
||||
bmp => 'image/bmp',
|
||||
gif => 'image/gif',
|
||||
ief => 'image/ief',
|
||||
jfif => 'image/jpeg',
|
||||
'jfif-tbnl' => 'image/jpeg',
|
||||
jpe => 'image/jpeg',
|
||||
jpg => 'image/jpeg',
|
||||
jpeg => 'image/jpeg',
|
||||
tif => 'image/tiff',
|
||||
tiff => 'image/tiff',
|
||||
fpx => 'image/vnd.fpx',
|
||||
fpix => 'image/vnd.fpx',
|
||||
ras => 'image/x-cmu-rast',
|
||||
pnm => 'image/x-portable-anymap',
|
||||
pbn => 'image/x-portable-bitmap',
|
||||
pgm => 'image/x-portable-graymap',
|
||||
ppm => 'image/x-portable-pixmap',
|
||||
rgb => 'image/x-rgb',
|
||||
xbm => 'image/x-xbitmap',
|
||||
xpm => 'image/x-xbitmap',
|
||||
xwd => 'image/x-xwindowdump',
|
||||
png => 'image/png',
|
||||
css => 'text/css',
|
||||
htm => 'text/html',
|
||||
html => 'text/html',
|
||||
shtml => 'text/html',
|
||||
text => 'text/plain',
|
||||
c => 'text/plain',
|
||||
cc => 'text/plain',
|
||||
'c++' => 'text/plain',
|
||||
h => 'text/plain',
|
||||
pl => 'text/plain',
|
||||
pm => 'text/plain',
|
||||
cgi => 'text/plain',
|
||||
txt => 'text/plain',
|
||||
java => 'text/plain',
|
||||
el => 'text/plain',
|
||||
tsv => 'text/tab-separated-values',
|
||||
etx => 'text/x-setext',
|
||||
mpg => 'video/mpeg',
|
||||
mpe => 'video/mpeg',
|
||||
mpeg => 'video/mpeg',
|
||||
mov => 'video/quicktime',
|
||||
qt => 'video/quicktime',
|
||||
avi => 'application/x-troff-msvideo',
|
||||
asf => 'video/x-ms-asf',
|
||||
movie => 'video/x-sgi-movie',
|
||||
mv => 'video/x-sgi-movie',
|
||||
wmv => 'video/x-ms-wmv',
|
||||
wma => 'video/x-ms-wma',
|
||||
mime => 'message/rfc822',
|
||||
eml => 'message/rfc822',
|
||||
xml => 'application/xml'
|
||||
) unless keys %CONTENT_EXT;
|
||||
|
||||
%CONTENT_EXT;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{mime_type} = __LINE__ . <<'END_OF_SUB';
|
||||
sub mime_type {
|
||||
# -------------------------------------------------------------------
|
||||
# Map content-type to image file
|
||||
#
|
||||
%MIME_TYPE = (
|
||||
'text/css' => 'html.gif',
|
||||
'text/html' => 'html.gif',
|
||||
'text/plain' => 'txt.gif',
|
||||
'application/pdf' => 'pdf.gif',
|
||||
'application/dvi' => 'dvi.gif',
|
||||
'application/postscript' => 'postscript.gif',
|
||||
'application/x-tex' => 'tex.gif',
|
||||
'application/x-texinfo' => 'tex.gif',
|
||||
'application/gtar' => 'tar.gif',
|
||||
'application/x-tar' => 'tar.gif',
|
||||
'application/x-ustar' => 'tar.gif',
|
||||
'application/zip' => 'zip.gif',
|
||||
'application/mspowerpoint' => 'ppt.gif',
|
||||
'application/msword' => 'word.gif',
|
||||
'application/msexcel' => 'excel.gif',
|
||||
'message/rfc822' => 'email.gif',
|
||||
'message/external-body' => 'email.gif',
|
||||
'multipart/alternative' => 'email.gif',
|
||||
'multipart/appledouble' => 'email.gif',
|
||||
'multipart/digest' => 'email.gif',
|
||||
'multipart/mixed' => 'email.gif',
|
||||
'multipart/voice-message' => 'sound.gif',
|
||||
'audio/basic' => 'sound.gif',
|
||||
'audio/x-aiff' => 'sound.gif',
|
||||
'audio/x-wav' => 'sound.gif',
|
||||
'audio/mpeg' => 'sound.gif',
|
||||
'image/gif' => 'image.gif',
|
||||
'image/ief' => 'image.gif',
|
||||
'image/jpeg' => 'image.gif',
|
||||
'image/tiff' => 'image.gif',
|
||||
'image/vnd.fpx' => 'image.gif',
|
||||
'image/x-cmu-rast' => 'image.gif',
|
||||
'image/x-portable-anymap' => 'image.gif',
|
||||
'image/x-portable-bitmap' => 'image.gif',
|
||||
'image/x-portable-graymap' => 'image.gif',
|
||||
'image/x-portable-pixmap' => 'image.gif',
|
||||
'image/x-rgb' => 'image.gif',
|
||||
'image/x-xbitmap' => 'image.gif',
|
||||
'image/x-xwindowdump' => 'image.gif',
|
||||
'image/png' => 'image.gif',
|
||||
'image/bmp' => 'image.gif',
|
||||
'video/mpeg' => 'video.gif',
|
||||
'video/quicktime' => 'video.gif',
|
||||
'video/x-ms-asf' => 'video.gif',
|
||||
'application/x-troff-msvideo' => 'video.gif',
|
||||
'video/x-sgi-movie' => 'video.gif',
|
||||
'video/x-ms-wmv' => 'wvideo.gif',
|
||||
'video/x-ms-wma' => 'wvideo.gif',
|
||||
) unless keys %MIME_TYPE;
|
||||
|
||||
%MIME_TYPE;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::MIMETypes - Methods to guess MIME Types of files.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::MIMETypes;
|
||||
|
||||
my $file = '/foo/bar/abc.doc';
|
||||
my $mime = GT::MIMETypes::guess_type($file);
|
||||
my $img = GT::MIMETypes::guess_image($file);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::MIMETypes provides two simple methods C<guess_type> and C<guess_image>.
|
||||
They take either a filename or a hash reference.
|
||||
|
||||
C<guess_type> returns the MIME type of the file, and guess_image returns an
|
||||
image name that represents the file.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: MIMETypes.pm,v 1.24 2005/04/02 08:08:46 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
979
site/glist/lib/GT/Mail.pm
Normal file
979
site/glist/lib/GT/Mail.pm
Normal file
@ -0,0 +1,979 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Mail.pm,v 1.70 2004/11/04 20:23:09 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to sending, creating, and
|
||||
# parsing emails.
|
||||
#
|
||||
|
||||
package GT::Mail;
|
||||
# ==================================================================
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw/$DEBUG @ISA $ERRORS $CRLF @HEADER $VERSION %CONTENT $CONTENT/;
|
||||
|
||||
# Internal modules
|
||||
use GT::Base;
|
||||
use GT::MIMETypes;
|
||||
use GT::Mail::Encoder;
|
||||
use GT::Mail::Parts;
|
||||
use GT::Mail::Send;
|
||||
|
||||
# Damn warnings
|
||||
$GT::Mail::error = '' if 0;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.70 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$CRLF = "\012";
|
||||
$| = 1;
|
||||
|
||||
$ERRORS = {
|
||||
PARSE => "Unable to parse message: %s",
|
||||
SEND => "Unable to send email: %s",
|
||||
NOIO => "No input to parse!",
|
||||
NOBOUND => "Multipart message has not boundary",
|
||||
NOEMAIL => "No message head was specified",
|
||||
NOBODY => "No body was found in message",
|
||||
};
|
||||
|
||||
# To guess the content-type for files by extension
|
||||
%CONTENT = GT::MIMETypes->content_ext;
|
||||
$CONTENT = \%CONTENT; # Other programs still access this as a hash reference.
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->new(
|
||||
# debug => 1,
|
||||
# to => 'user1@domain',
|
||||
# from => 'user2@domain',
|
||||
# subject => 'Hi Alex',
|
||||
# type => 'multipart/mixed',
|
||||
# ...
|
||||
# );
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returm a new mail object. If you pass in the header information the new
|
||||
# mail's header will be initialized with those fields.
|
||||
my $this = shift;
|
||||
my $self;
|
||||
|
||||
# Calling this as an object method does not create a new object.
|
||||
if (ref $this) { $self = $this }
|
||||
else { $self = bless {}, $this }
|
||||
|
||||
$self->args(@_) if @_;
|
||||
exists($self->{_debug}) or $self->{_debug} = $DEBUG;
|
||||
|
||||
$self->debug("Created new object ($self).") if ($self->{_debug} > 1);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub args {
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
elsif (ref $_[0] eq 'HASH') { $opt = shift }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? delete $opt->{debug} : $DEBUG;
|
||||
$self->{smtp} = delete $opt->{smtp} || '';
|
||||
$self->{smtp_port} = delete $opt->{smtp_port} || '';
|
||||
$self->{smtp_ssl} = delete $opt->{smtp_ssl} || '';
|
||||
$self->{smtp_user} = delete $opt->{smtp_user} || '';
|
||||
$self->{smtp_pass} = delete $opt->{smtp_pass} || '';
|
||||
$self->{pbs_user} = delete $opt->{pbs_user} || '';
|
||||
$self->{pbs_pass} = delete $opt->{pbs_pass} || '';
|
||||
$self->{pbs_host} = delete $opt->{pbs_host} || '';
|
||||
$self->{pbs_port} = delete $opt->{pbs_port} || '';
|
||||
$self->{pbs_auth_mode} = delete $opt->{pbs_auth_mode} || 'PASS';
|
||||
$self->{pbs_ssl} = delete $opt->{pbs_ssl} || '';
|
||||
$self->{flags} = delete $opt->{flags} || '';
|
||||
$self->{sendmail} = delete $opt->{sendmail} || '';
|
||||
$self->{header_charset} = delete $opt->{header_charset} || 'ISO-8859-1';
|
||||
|
||||
if (keys %{$opt} and !$self->{head}) {
|
||||
$self->{head} = $self->new_part($opt);
|
||||
}
|
||||
elsif (keys %{$opt} and $self->{head}) {
|
||||
$self->header($self->{head}, $opt);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->parse(\*FH);
|
||||
# ------------------
|
||||
# $obj->parse('/path/to/file');
|
||||
# -----------------------------
|
||||
# $obj->parse($SCALAR_REF -or- $SCALAR);
|
||||
# --------------------------------------
|
||||
# Takes either a path to a file for a file handle. Returns 1 on success and
|
||||
# undef on failure. If a filehandle is specified this will attempt to seek back
|
||||
# to 0, 0 on exit.
|
||||
#
|
||||
my ($self, $io) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$self->_set_io($io) or return;
|
||||
$self->debug("\n\t--------------> Parsing email.") if $self->{_debug};
|
||||
$self->{head} = $self->{parser}->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
$self->debug("\n\t<-------------- Email parsed.") if $self->{_debug};
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub parse_head {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->parse_head (\*FH);
|
||||
# ------------------------
|
||||
# $obj->parse_head ('/path/to/file');
|
||||
# -----------------------------------
|
||||
# This method does the exact same thing as the parse method except it will only
|
||||
# parse the header of the file or filehandle. This is a nice way to save
|
||||
# overhead when all you need is the header parsed and do not care about the
|
||||
# rest of the email.
|
||||
# NOTE: The top level part is returned from this and not stored.
|
||||
#
|
||||
my ($self, $io) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$self->_set_io($io) or return;
|
||||
$self->debug("\n\t--------------> Parsing head") if $self->{_debug};
|
||||
my $part = $self->{parser}->parse_head or $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
$self->debug("\n\t<-------------- Head parsed") if $self->{_debug};
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub parser {
|
||||
# -----------------------------------------------------------------------------
|
||||
# my $parser = $mail->parser;
|
||||
# ---------------------------
|
||||
# $mail->parser($parser);
|
||||
# -----------------------
|
||||
# Set or get method for the parser object that is used when you call
|
||||
# parse_head() or parse(). This object must conform to the method parse and
|
||||
# parse_head. If no object is passed to this method a GT::Mail::Parse object is
|
||||
# created when needed.
|
||||
#
|
||||
my ($self, $parser) = @_;
|
||||
if (defined $parser) {
|
||||
$self->{parser} = $parser;
|
||||
$self->{head} = $parser->top_part;
|
||||
}
|
||||
return $self->{parser};
|
||||
}
|
||||
|
||||
sub send {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4650, To => '...', ...);
|
||||
# ------------------------------------------------------------------------------------
|
||||
# $obj->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4560);
|
||||
# -----------------------------------------------------------------
|
||||
# $obj->send(sendmail => '/path/to/sendmail', flags => $additional_flags);
|
||||
# ------------------------------------------------------------------------
|
||||
# Sends the current email through either smtp or sendmail. The sendmail send
|
||||
# takes additional arguments as flags that get passed to sendmail (e.g.
|
||||
# "-t -oi -oem"). If these flags are specified they override the default which
|
||||
# is "-t -oi -oem". The smtp send also looks for smtp_port and smtp_ssl, but
|
||||
# these are optional and default to port 110, non-encrypted. Note that using
|
||||
# an SSL encrypted connection requires Net::SSLeay. Also not that attempting
|
||||
# to establish an SSL connection when Net::SSLeay (at least version 1.06) is
|
||||
# not available will cause a fatal error to occur.
|
||||
#
|
||||
my $self = shift;
|
||||
unless (ref $self) {
|
||||
$self = $self->new(@_);
|
||||
}
|
||||
elsif (@_) {
|
||||
$self->args(@_);
|
||||
}
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
|
||||
# Set a Message-Id if we don't have one set already
|
||||
my $host = $self->{smtp} && $self->{smtp} ne 'localhost' && $self->{smtp} !~ /^\s*127\.\d+\.\d+\.\d+\s*$/ ? $self->{smtp} : $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost' ? $ENV{SERVER_NAME} : '';
|
||||
if (not defined $self->{head}->get('Message-Id') and $host) {
|
||||
$self->{head}->set('Message-Id' => '<' . time . '.' . $$ . rand(10000) . '@' . $host . '>');
|
||||
}
|
||||
|
||||
if ($self->{sendmail} and -e $self->{sendmail} and -x _) {
|
||||
$self->debug("\n\t--------------> Sending email through Sendmail path: ($self->{sendmail})") if $self->{_debug};
|
||||
my @flags = exists($self->{flags}) ? (flags => $self->{flags}) : ();
|
||||
my $return = ($self->parse_address($self->{head}->get('Reply-To') || $self->{head}->get('From')))[1];
|
||||
$self->{head}->set('Return-Path' => "<$return>") unless $self->{head}->get('Return-Path');
|
||||
GT::Mail::Send->sendmail(
|
||||
debug => $self->{_debug},
|
||||
path => $self->{sendmail},
|
||||
mail => $self,
|
||||
@flags
|
||||
) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
|
||||
$self->debug("\n\t<-------------- Email sent through Sendmail") if $self->{_debug};
|
||||
}
|
||||
elsif ($self->{smtp} and $self->{smtp} =~ /\S/) {
|
||||
# SMTP requires \r\n
|
||||
local $CRLF = "\015\012";
|
||||
local $GT::Mail::Parts::CRLF = "\015\012";
|
||||
local $GT::Mail::Encoder::CRLF = "\015\012";
|
||||
$self->{head}->set(date => $self->date_stamp) unless ($self->{head}->get('date'));
|
||||
$self->debug("\n\t--------------> Sending email through SMTP host: ($self->{smtp}:$self->{smtp_port})") if $self->{_debug};
|
||||
GT::Mail::Send->smtp(
|
||||
debug => $self->{_debug},
|
||||
host => $self->{smtp},
|
||||
port => $self->{smtp_port}, # Optional; GT::Mail::Send will set a default if not present
|
||||
ssl => $self->{smtp_ssl}, # Make sure Net::SSLeay is available if you use this
|
||||
user => $self->{smtp_user}, # Optional; Used for SMTP AUTH (CRAM-MD5, PLAIN, LOGIN)
|
||||
pass => $self->{smtp_pass},
|
||||
pbs_host => $self->{pbs_host}, # Optional; Perform a POP3 login before sending mail
|
||||
pbs_port => $self->{pbs_port},
|
||||
pbs_user => $self->{pbs_user},
|
||||
pbs_pass => $self->{pbs_pass},
|
||||
pbs_auth_mode => $self->{pbs_auth_mode},
|
||||
pbs_ssl => $self->{pbs_ssl},
|
||||
mail => $self
|
||||
) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
|
||||
$self->debug("\n\t<-------------- Email sent through SMTP") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
return $self->error("BADARGS", "FATAL", '$obj->send (%opts); smtp or sendmail and a head part must exist at this point.');
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub top_part {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->top_part ($part);
|
||||
# -----------------------
|
||||
# This allows you to set the top level part directly.
|
||||
# This is used to produce the email when sending or writing to file.
|
||||
#
|
||||
# my $top = $obj->top_part;
|
||||
# -------------------------
|
||||
# Returns the current top level part.
|
||||
#
|
||||
|
||||
my ($self, $part) = @_;
|
||||
if ($part and ref $part) {
|
||||
$self->{head} = $part;
|
||||
}
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub new_part {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->new_part;
|
||||
# ---------------
|
||||
# $obj->new_part(
|
||||
# to => 'user1@domain',
|
||||
# from => 'user2@domain',
|
||||
# subject => 'Hi Alex',
|
||||
# type => 'multipart/mixed',
|
||||
# ...
|
||||
# );
|
||||
# ---------------------------------
|
||||
# Returns a new part. If arguments a given they are passed to the header method
|
||||
# in the parts module. See the parts module for details.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $part = new GT::Mail::Parts (debug => $self->{_debug}, header_charset => $self->{header_charset});
|
||||
$self->header($part, @_) if @_;
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub header {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->header(%header);
|
||||
# ----------------------
|
||||
# Mostly private method to set the arguments for the emails header.
|
||||
# This is called by new and new_part.
|
||||
# The options are:
|
||||
#
|
||||
# disposition => Sets the Content-Disposition.
|
||||
# filename => Sets the Content-Disposition to attachment and the
|
||||
# file name to what to specify.
|
||||
# encoding => Sets the Content-Transfer-Encoding (You really
|
||||
# should not set this).
|
||||
# header_charset => The header encoding charset.
|
||||
# type => Sets the Content-Type.
|
||||
# body_data => Sets the top level body data to the in memory string
|
||||
# specified.
|
||||
# msg => Same as body_data.
|
||||
# body_handle => Sets the top level body to the File Handle.
|
||||
# body_path => Sets the top level body path.
|
||||
#
|
||||
|
||||
my $self = shift;
|
||||
my $part = shift;
|
||||
|
||||
my $opt;
|
||||
if (!@_) { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
elsif (ref $_[0] and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
else { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }
|
||||
|
||||
for my $tag (keys %{$opt}) {
|
||||
next unless defined $opt->{$tag};
|
||||
my $key = $tag;
|
||||
if ($tag eq 'disposition') { $tag = 'Content-Disposition' }
|
||||
elsif ($tag eq 'filename') { $tag = 'Content-Disposition'; $opt->{$key} = 'attachment; filename="' . $opt->{$key} . '"' }
|
||||
elsif ($tag eq 'encoding') { $tag = 'Content-Transfer-Encoding' }
|
||||
elsif ($tag eq 'type') { $part->mime_type($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_data') { $part->body_data($opt->{$tag}); next }
|
||||
elsif ($tag eq 'header_charset') { $part->header_charset($opt->{$tag}); next }
|
||||
|
||||
# For Alex :)
|
||||
elsif ($tag eq 'msg') { $part->body_data($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_handle') { $part->body_handle($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_path') { $part->body_path($opt->{$tag}); next }
|
||||
$self->debug("Setting ($tag) to ($opt->{$key})") if ($self->{_debug} > 1);
|
||||
$part->set($tag => $opt->{$key});
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub attach {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->attach($mail_object);
|
||||
# ---------------------------
|
||||
# Attaches an rfc/822 to the current email. $mail_object is a GT::Mail object.
|
||||
#
|
||||
# $obj->attach(
|
||||
# disposition => 'inline',
|
||||
# type => 'text/plain',
|
||||
# body_data => 'Hello how are ya'
|
||||
# );
|
||||
# --------------------------------------
|
||||
# Attaches the given data to the email. See header for a list of the options.
|
||||
#
|
||||
my $self = shift;
|
||||
if (!$self->{head}) { return $self->error("NOEMAIL", "FATAL") }
|
||||
|
||||
my $attach;
|
||||
if (ref $_[0] eq ref $self) {
|
||||
$self->debug("Adding rfc/822 email attachment.") if $self->{_debug};
|
||||
push @{$self->{mail_attach}}, @_;
|
||||
return 1;
|
||||
}
|
||||
elsif (ref $_[0] eq 'GT::Mail::Parts') {
|
||||
$attach = $_[0];
|
||||
}
|
||||
else {
|
||||
$attach = $self->new_part(@_);
|
||||
}
|
||||
$self->debug("Adding attachment.") if $self->{_debug};
|
||||
|
||||
# Guess the content-type if none was specified
|
||||
if (!$attach->mime_type and $attach->body_path) {
|
||||
(my $ext = $attach->body_path) =~ s/^.*\.//;
|
||||
$attach->mime_type(exists($CONTENT{$ext}) ? $CONTENT{$ext} : 'application/octet-stream');
|
||||
}
|
||||
$self->{head}->parts($attach);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub to_string { shift->as_string }
|
||||
|
||||
sub as_string {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->as_string;
|
||||
# ----------------
|
||||
# Returns the entire email as a sting. The parts will be encoded for sending at
|
||||
# this point.
|
||||
# NOTE: Not a recommended method for emails with binary attachments.
|
||||
my $self = shift;
|
||||
my $ret = '';
|
||||
$self->build_email(sub { $ret .= $_[0] });
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub build_email {
|
||||
my ($self, $code) = @_;
|
||||
$GT::Mail::Encoder::CRLF = $CRLF;
|
||||
# Need a code ref to continue.
|
||||
ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub {do something });');
|
||||
|
||||
$self->debug("\n\t--------------> Creating email") if $self->{_debug};
|
||||
# Need the head to contiue
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
unless ($self->{head}->get('MIME-Version')) { $self->{head}->set('MIME-Version', '1.0') }
|
||||
|
||||
my $io = $self->_get_body_handle($self->{head});
|
||||
my $bound = $self->{head}->multipart_boundary;
|
||||
|
||||
# If the message has parts
|
||||
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
$self->debug("Creating multipart email.") if $self->{_debug};
|
||||
$self->_build_multipart_head($code, $io);
|
||||
}
|
||||
|
||||
# Else we are single part and have either a body IO handle or the body is in memory
|
||||
elsif (defined $io) {
|
||||
$self->debug("Creating singlepart email.") if $self->{_debug};
|
||||
$self->_build_singlepart_head($code, $io);
|
||||
}
|
||||
else {
|
||||
$self->error("NOBODY", "WARN");
|
||||
$code->($self->{head}->header_as_string . $CRLF . $CRLF . $GT::Mail::Parse::ENCODED);
|
||||
}
|
||||
|
||||
# If we have parts go through all of them and add them.
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
my $num_parts = $#{$self->{head}->{parts}};
|
||||
for my $num (0 .. $num_parts) {
|
||||
next unless $self->{head}->{parts}->[$num];
|
||||
$self->debug("Creating part ($num).") if $self->{_debug};
|
||||
$self->_build_parts($code, $self->{head}->{parts}->[$num]);
|
||||
if ($num_parts == $num) {
|
||||
$self->debug("Boundary\n\t--$bound--") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . '--' . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Add the epilogue if we are multipart
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
my $epilogue = join('', @{ $self->{head}->epilogue || [] }) || '';
|
||||
$epilogue =~ s/\015?\012//g;
|
||||
$self->debug("Setting epilogue to ($epilogue)") if $self->{_debug};
|
||||
$code->($epilogue . $CRLF . $CRLF) if $epilogue;
|
||||
}
|
||||
$self->debug("\n\t<-------------- Email created.") if $self->{_debug};
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub write {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->write ('/path/to/file');
|
||||
# ------------------------------
|
||||
# $obj->write (*FH);
|
||||
# ------------------
|
||||
# Writes the email to the specified file or file handle. The email will be
|
||||
# encoded properly. This is nice for writing to an mbox file. If a file path
|
||||
# is specified this will attempt to open it >. Returns 1 on success and undef
|
||||
# on failure.
|
||||
#
|
||||
my ($self, $file) = @_;
|
||||
my $io;
|
||||
if (ref($file) and (ref($file) eq 'GLOB') and fileno($file)) {
|
||||
$self->debug("Filehandle passed to write: fileno (" . fileno($file) . ").") if $self->{_debug};
|
||||
$io = $file;
|
||||
}
|
||||
elsif (open FH, ">$file") {
|
||||
$io = \*FH;
|
||||
$self->debug("Opening ($file) for reading.") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
return $self->error("BADARGS", "FATAL", '$obj->write ("/path/to/file"); -or- $obj->write (\*FH);');
|
||||
}
|
||||
$self->build_email(sub { print $io @_ }) or return;
|
||||
$self->debug("Email written to fileno (" . fileno($io) . ")") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _set_io {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private function to decide what to do with the arguments passed into parse
|
||||
# and parse_head.
|
||||
#
|
||||
my ($self, $io) = @_;
|
||||
|
||||
CASE: {
|
||||
ref($io) eq 'SCALAR' and do { $self->{parser}->in_string($io); last CASE };
|
||||
ref($io) and ref($io) =~ /^GLOB|FileHandle$/ and do { $self->{parser}->in_handle($io); last CASE };
|
||||
-f $io and do { $self->{parser}->in_file($io); last CASE };
|
||||
ref $io or do { $self->{parser}->in_string($io); last CASE };
|
||||
return $self->error("NOIO", "FATAL");
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _encoding {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to guess the encoding type.
|
||||
#
|
||||
my ($self, $part) = @_;
|
||||
my $encoding;
|
||||
$encoding = $part->mime_attr('content-transfer-encoding');
|
||||
if ($encoding and lc($encoding) ne '-guess') {
|
||||
return $encoding;
|
||||
}
|
||||
else {
|
||||
return $part->suggest_encoding;
|
||||
}
|
||||
}
|
||||
|
||||
sub date_stamp {
|
||||
# --------------------------------------------------------------------------
|
||||
# Set an RFC date, e.g.: Mon, 08 Apr 2002 13:56:22 -0700
|
||||
#
|
||||
my $self = shift;
|
||||
require GT::Date;
|
||||
local @GT::Date::MONTHS_SH = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
|
||||
local @GT::Date::DAYS_SH = qw/Sun Mon Tue Wed Thu Fri Sat/;
|
||||
return GT::Date::date_get(time, '%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o%');
|
||||
}
|
||||
|
||||
sub parse_address {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Parses out the name and e-mail address of a given "address". For example,
|
||||
# from: "Jason Rhinelander" <jason@gossamer-threads.com>, this will return
|
||||
# ('Jason Rhinelander', 'jason@gossamer-threads.com'). It handes escapes as
|
||||
# well - "Jason \(\"jagerman\"\) Rhinelander" <jason@gossamer-threads.com>
|
||||
# returns 'Jason ("jagerman") Rhinelander' for the name.
|
||||
#
|
||||
my ($self, $email_from) = @_;
|
||||
|
||||
my ($name, $email) = ('', '');
|
||||
if ($email_from =~ /"?((?:[^<"\\]|\\.)+?)"?\s*<([^>]*)>/) {
|
||||
($name, $email) = ($1, $2);
|
||||
$name =~ s/\\(.)/$1/g;
|
||||
$name =~ s/^\s*$//;
|
||||
}
|
||||
elsif ($email_from =~ /<([^>]*)>/) {
|
||||
$email = $1;
|
||||
}
|
||||
else {
|
||||
$email = $email_from || '';
|
||||
$email =~ s/\([^)]+\)//g;
|
||||
}
|
||||
return ($name, $email);
|
||||
}
|
||||
|
||||
sub _get_body_handle {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to get a body handle on a given part.
|
||||
#
|
||||
my ($self, $part) = @_;
|
||||
my $in = $part->body_in || 'NONE';
|
||||
my $io;
|
||||
if ($in eq 'MEMORY') {
|
||||
$self->debug("Body is in MEMORY.") if $self->{_debug};
|
||||
return $part->body_data;
|
||||
}
|
||||
elsif ($in eq 'FILE') {
|
||||
$self->debug("Body is in FILE: " . $part->body_path) if $self->{_debug};
|
||||
$io = $part->open('r');
|
||||
}
|
||||
elsif ($in eq 'HANDLE') {
|
||||
$self->debug("Body is in HANDLE.") if $self->{_debug};
|
||||
$io = $part->body_handle;
|
||||
binmode($io);
|
||||
}
|
||||
return $io;
|
||||
}
|
||||
|
||||
sub _build_multipart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a multipart header.
|
||||
#
|
||||
my ($self, $code, $io) = @_;
|
||||
my $bound = $self->{head}->multipart_boundary;
|
||||
my $encoding = $self->_encoding($self->{head});
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$self->{head}->set(
|
||||
'Content-Transfer-Encoding' => $encoding
|
||||
);
|
||||
if (defined $io) {
|
||||
my $mime = 'text/plain';
|
||||
my ($type, $subtype) = split '/' => $self->{head}->mime_type;
|
||||
if ($type and lc($type) ne 'multipart') {
|
||||
$subtype ||= 'mixed';
|
||||
$mime = "$type/$subtype";
|
||||
}
|
||||
my %new = (
|
||||
type => $mime,
|
||||
encoding => $encoding,
|
||||
disposition => "inline"
|
||||
);
|
||||
|
||||
# Body is in a handle
|
||||
if (ref $io) { $new{body_handle} = $io }
|
||||
|
||||
# Body is in memory
|
||||
else { $new{body_data} = $io }
|
||||
|
||||
my $new = $self->new_part(%new);
|
||||
$self->{head}->{body_in} = 'NONE';
|
||||
unshift @{$self->{head}->{parts}}, $new;
|
||||
}
|
||||
$bound ||= "---------=_" . time . "-$$-" . int(rand(time)/2);
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $self->{head}->get('Content-Type');
|
||||
if ($c !~ /\Q$bound/i) {
|
||||
if ($c and lc($c) !~ /boundary=/) {
|
||||
$c =~ /multipart/ or $c = 'multipart/mixed';
|
||||
$self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
|
||||
$self->{head}->set('Content-Type' => $c . qq|; boundary="$bound"|);
|
||||
}
|
||||
else {
|
||||
$self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
|
||||
$self->{head}->set('Content-Type' => qq!multipart/mixed; boundary="$bound"!);
|
||||
}
|
||||
}
|
||||
|
||||
my $preamble = join('', @{$self->{head}->preamble || []})
|
||||
|| "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug("Setting preamble to ($preamble).") if $self->{_debug};
|
||||
(my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_singlepart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a single part header.
|
||||
#
|
||||
my ($self, $code, $io) = @_;
|
||||
my $encoding = $self->_encoding($self->{head});
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$self->{head}->set('Content-Transfer-Encoding' => $encoding);
|
||||
(my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$code->($head . $CRLF);
|
||||
$self->debug("Encoding body with ($encoding).") if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
debug => $self->{_debug},
|
||||
encoding => $encoding,
|
||||
in => $io,
|
||||
out => $code
|
||||
) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder::error);
|
||||
|
||||
# Must seek to the beginning for additional calls
|
||||
seek($io, 0, 0) if ref $io;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method that builds the parts for the email.
|
||||
#
|
||||
my ($self, $code, $part) = @_;
|
||||
|
||||
# Need a code ref to continue.
|
||||
ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub { do something });');
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
|
||||
my ($body, $io, $encoding, $bound);
|
||||
|
||||
# Get the io handle for the body
|
||||
$io = $self->_get_body_handle($part);
|
||||
$bound = $part->multipart_boundary;
|
||||
|
||||
# The body is in an io stream.
|
||||
if (defined $io) {
|
||||
|
||||
# Find the encoding for the part and set it.
|
||||
$encoding = $self->_encoding($part);
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$part->set('Content-Transfer-Encoding' => $encoding);
|
||||
}
|
||||
|
||||
# If the message has parts and has a multipart boundary
|
||||
if ((@{$part->{parts}} > 0) and ($bound)) {
|
||||
$self->debug("Part is multpart.") if $self->{_debug};
|
||||
|
||||
# Set the multipart boundary
|
||||
$self->debug("Setting boundary to ($bound).") if $self->{_debug};
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $part->get('Content-Type');
|
||||
if ($c) {
|
||||
$self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
|
||||
$part->set('Content-Type' => $c . qq|; boundary="$bound"|);
|
||||
}
|
||||
else {
|
||||
$self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
|
||||
$part->set('Content-Type' => qq!multipart/mixed; boundary="$bound"!);
|
||||
}
|
||||
|
||||
my $preamble = join('', @{$part->preamble || []})
|
||||
|| "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug("Setting preamble to ($preamble).") if $self->{_debug};
|
||||
(my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($head . $CRLF . $preamble . $CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Part is single part.") if $self->{_debug};
|
||||
(my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$code->($head . $CRLF);
|
||||
}
|
||||
|
||||
# Set the body only if we have one. We would not have one on the head an multipart
|
||||
if ($io) {
|
||||
$self->debug("Encoding body with ($encoding).") if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
encoding => $encoding,
|
||||
debug => $self->{_debug},
|
||||
in => $io,
|
||||
out => $code
|
||||
) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder);
|
||||
|
||||
# Must reseek IO for multiple calls.
|
||||
seek($io, 0, 0) if ref $io;
|
||||
}
|
||||
else {
|
||||
$self->debug("Part has no body!") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Add the rest of the parts
|
||||
if (@{$part->{parts}} > 0) {
|
||||
$self->debug("Part has parts.") if $self->{_debug};
|
||||
my $num_parts = $#{$part->{parts}};
|
||||
for my $num (0 .. $num_parts) {
|
||||
next unless $part->{parts}->[$num];
|
||||
$self->debug("Creating part ($num).") if $self->{_debug};
|
||||
$self->_build_parts($code, $part->{parts}->[$num]) or return;
|
||||
if ($bound) {
|
||||
if ($num_parts == $num) {
|
||||
$self->debug("Boundary\n\t--$bound--") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . '--' . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
undef $io;
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail - A simple interface to parsing, sending, and creating email.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail;
|
||||
|
||||
# Create and Sending
|
||||
GT::Mail->send(
|
||||
smtp => 'gossamer-threads.com',
|
||||
smtp_port => 110, # optional; 110/465 (normal/SSL) will be used for the default
|
||||
smtp_ssl => 1, # establish an SSL connection. Requires Net::SSLeay 1.06 or newer.
|
||||
to => 'scott@gossamer-threads.com',
|
||||
from => 'scott@gossamer-threads.com',
|
||||
subject => 'Hello!!',
|
||||
msg => 'I am a text email'
|
||||
) or die "Error: $GT::Mail::error";
|
||||
|
||||
# Parsing and sending
|
||||
my $mail = GT::Mail->new(debug => 1);
|
||||
|
||||
# Parse an email that is in a file called mail.test
|
||||
my $parser = $mail->parse('mail.test') or die "Error: $GT::Mail::error";
|
||||
|
||||
# Change who it is to
|
||||
$parser->set("to", 'scott@gossamer-threads.com');
|
||||
|
||||
# Add an attachment to it
|
||||
$mail->attach (
|
||||
type => 'text/plain',
|
||||
encoding => '-guess',
|
||||
body_path => 'Mail.pm',
|
||||
filename => 'Mail.pm'
|
||||
);
|
||||
|
||||
# Send the email we just parsed and modified
|
||||
$mail->send(sendmail => '/usr/sbin/sendmail') or die "Error: $GT::Mail::error";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail is a simple interface for parsing, creating, and sending email. It
|
||||
uses GT::Mail::Send to send email and GT::Mail::Parse to parse and store email
|
||||
data structurs. All the creation work is done from within GT::Mail.
|
||||
|
||||
=head2 Creating a new GT::Mail object
|
||||
|
||||
The arguments to new() in GT::Mail are mostly the same for all the class
|
||||
methods in GT::Mail so I will be refering back to these further down. Mostly
|
||||
these arguments are used to set parts of the header for creating an email. The
|
||||
arguments can be passed in as either a hash or a hash ref. Any arguments aside
|
||||
from these will be added to the content header as raw header fields. The
|
||||
following is a list of the keys and a brief description.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this object. Anything but zero will produce ouput on
|
||||
STDERR.
|
||||
|
||||
=item disposition
|
||||
|
||||
Sets the Content-Disposition.
|
||||
|
||||
=item filename
|
||||
|
||||
Sets the Content-Disposition to attachment and the file name to what to
|
||||
specify.
|
||||
|
||||
=item encoding
|
||||
|
||||
Sets the Content-Transfer-Encoding (You really should not set this).
|
||||
|
||||
=item type
|
||||
|
||||
Sets the Content-Type.
|
||||
|
||||
=item body_data
|
||||
|
||||
Sets the top level body data to the in memory string specified.
|
||||
|
||||
=item msg
|
||||
|
||||
Same as body_data.
|
||||
|
||||
=item body_handle
|
||||
|
||||
Sets the top level body to the File Handle.
|
||||
|
||||
=item body_path
|
||||
|
||||
Sets the top level body path.
|
||||
|
||||
=back
|
||||
|
||||
=head2 parser - Set or get the parse object.
|
||||
|
||||
my $parser = $mail->parser;
|
||||
$mail->parser($parser);
|
||||
|
||||
Set or get method for the parser object that is used when you call parse_head()
|
||||
or parse(). This object must conform to the method parse and parse_head. If no
|
||||
object is passed to this method a L<GT::Mail::Parse> object is created when
|
||||
needed.
|
||||
|
||||
=head2 parse - Parsing an email.
|
||||
|
||||
Instance method that returns a parts object. Emails are stored recursivly in
|
||||
parts object. That is emails can have parts within parts within parts etc.. See
|
||||
L<GT::Mail::Parts> for details on the methods supported by the parts object
|
||||
that is returned.
|
||||
|
||||
The parse() method takes only one argument. It can be a GLOB ref to a file
|
||||
handle, a FileHandle object, or the path to a file. In any case the IO must
|
||||
contain a valid formated email.
|
||||
|
||||
Once an email is parsed, you can make changes to it as you need and call the
|
||||
send method to send it or call the write method to write it to file, etc.
|
||||
|
||||
This method will return false if an error occurs when parsing. The error
|
||||
message will be set in $GT::Mail::error.
|
||||
|
||||
=head2 parse_head - Parsing just the head.
|
||||
|
||||
This method does the exact same thing as the parse method but it will only
|
||||
parse the top level header of the email. Any IO's will be reset after the
|
||||
parsing.
|
||||
|
||||
Use this method if whether you want to parse and decode the body of the email
|
||||
depends on what is in the header of the email or if you only need access to the
|
||||
header. None of the parts will contain a body.
|
||||
|
||||
=head2 send - Sending an email.
|
||||
|
||||
Class/Instance method for sending email. It sends the currently in memory
|
||||
email. This means, if you parse an email, that email is in memory, if you
|
||||
specify params for an email to new(), that is the email that gets sent. You can
|
||||
also specify the params for the email to this method.
|
||||
|
||||
=head2 top_part - Getting a Parts object.
|
||||
|
||||
Instance method to set or get the top level part. If you are setting this, the
|
||||
object must be from L<GT::Mail::Parts>. You can use this to retrieve the part
|
||||
object after you specify params to create an email. This object will contain
|
||||
all the other parts for the email. e.g. attachments and emails that are
|
||||
attached. See L<GT::Mail::Parts> for more details on this object.
|
||||
|
||||
=head2 new_part - Creating a Parts object.
|
||||
|
||||
Instance method to get a new part object. This method takes the same arguments
|
||||
as the new() constructor. Returns the new part object. The part object is
|
||||
added to the current email only if arguments are given otherwize just returns
|
||||
an empty part.
|
||||
|
||||
=head2 attach - Attaching to an email.
|
||||
|
||||
Instance method to attach to the in memory email. You can pass in a GT::Mail
|
||||
object or you can pass the same arguments you would pass to new() to specify
|
||||
all the information about the attachment. In addition if you specify a file
|
||||
path and do not specify a mime type, this will attempt to guess the mime type
|
||||
from the file extention.
|
||||
|
||||
=head2 to_string - Getting the email as a string.
|
||||
|
||||
Returns the entire email as a string. Do not use this function if you have
|
||||
attachments and are worried about memory ussage.
|
||||
|
||||
=head2 as_string - Getting the email as a string.
|
||||
|
||||
Same as to_string.
|
||||
|
||||
=head2 build_email - Building an email.
|
||||
|
||||
Instance method that builds the currently in memory email. This method takes
|
||||
one argument, a code ref. It calles the code ref with one argument. The code
|
||||
ref is called for each section of the email that is created. A good example of
|
||||
how to use this is what the as_string method does:
|
||||
|
||||
my $ret = '';
|
||||
$obj->build_email(sub { $ret .= $_[0] });
|
||||
|
||||
This puts the entire created email into the string $ret. You can use this, for
|
||||
example to print the email to a filehandle (which is what the write() method
|
||||
does).
|
||||
|
||||
=head2 write - Writing an email to a file handle.
|
||||
|
||||
Instance mothod that writes the currently in memory email to a file or file
|
||||
handle. The only arguments this method takes is a file or a reference to a glob
|
||||
that is a filehandle or FileHandle object.
|
||||
|
||||
=head2 naming - Setting the naming scheme.
|
||||
|
||||
Instance method to specify a naming scheme for parsing emails. Calling this
|
||||
after the email is parsed has no effect. This method just wraps to the one in
|
||||
L<GT::Mail::Parse>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Mail.pm,v 1.70 2004/11/04 20:23:09 brewt Exp $
|
||||
|
||||
=cut
|
||||
1282
site/glist/lib/GT/Mail/BulkMail.pm
Normal file
1282
site/glist/lib/GT/Mail/BulkMail.pm
Normal file
File diff suppressed because it is too large
Load Diff
524
site/glist/lib/GT/Mail/Editor.pm
Normal file
524
site/glist/lib/GT/Mail/Editor.pm
Normal file
@ -0,0 +1,524 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Editor
|
||||
#
|
||||
# Author: Jason Rhinelander
|
||||
# Revision: $Id: Editor.pm,v 1.24 2005/01/18 23:06:40 bao Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# The backend to a web-based e-mail template editor. See the pod for
|
||||
# instructions. This is designed the be used primarily from templates.
|
||||
# This module respects local directories on saving, and both local and
|
||||
# inheritance directories when loading.
|
||||
#
|
||||
# Also, any subclasses must be (something)::Editor
|
||||
#
|
||||
|
||||
package GT::Mail::Editor;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG $ERRORS @ISA $ATTRIBS);
|
||||
|
||||
use GT::Base;
|
||||
use GT::Template;
|
||||
|
||||
@ISA = 'GT::Base';
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.24 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$ERRORS = {
|
||||
PARSE => "An error occured while parsing: %s",
|
||||
NODIR => "Template directory not specified",
|
||||
BADDIR => "Template directory '%s' does not exist or has the permissions set incorrectly",
|
||||
NOFILE => "No template filename specified",
|
||||
CANT_CREATE_DIR => "Unable to create directory '%s': %s",
|
||||
BADFILE => "Template '%s' does not exist or is not readable",
|
||||
SAVEERROR => "Unable to open '%s' for writing: %s",
|
||||
LOADERROR => "Unable to open '%s' for reading: %s",
|
||||
RECURSION => "Recursive inheritance detected and interrupted: '%s'",
|
||||
INVALIDDIR => "Invalid template directory %s",
|
||||
INVALIDTPL => "Invalid template %s",
|
||||
};
|
||||
|
||||
$ATTRIBS = {
|
||||
dir => '',
|
||||
template => '',
|
||||
file => '',
|
||||
headers => undef,
|
||||
extra_headers => '',
|
||||
body => ''
|
||||
};
|
||||
|
||||
# GT::Mail::Editor::tpl_save(header => To => $header_to, header => From => $header_from, ..., extra_headers => $extra_headers)
|
||||
# ($extra_headers will be parsed). Everything is optional, but you should give something to build headers from.
|
||||
# It is not necessary to use To, From, etc. - you can enter them directly in the "extra_headers" field.
|
||||
sub tpl_save {
|
||||
# Have to extract the three-argument arguments BEFORE getting $self
|
||||
my @headers;
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if ($_[$i] eq 'header') {
|
||||
push @headers, (splice @_, $i, 3)[1,2];
|
||||
redo;
|
||||
}
|
||||
}
|
||||
my $self = &_get_self;
|
||||
for (my $i = 0; $i < @headers; $i += 2) {
|
||||
$self->{headers}->{$headers[$i]} = $headers[$i+1];
|
||||
}
|
||||
if ($self->{extra_headers}) {
|
||||
for (split /\s*\n\s*/, $self->{extra_headers}) { # This will weed out any blank lines
|
||||
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
||||
$self->{headers}->{$key} = $value if $key and $value;
|
||||
}
|
||||
}
|
||||
my $dir;
|
||||
if ($self->{dir} and $self->{template}) {
|
||||
$dir = "$self->{dir}/$self->{template}/local";
|
||||
if (!-d $dir) {
|
||||
# Attempt to create the "local" subdirectory
|
||||
mkdir($dir, 0777) or return $self->error(CANT_CREATE_DIR => 'FATAL' => $dir => "$!");
|
||||
chmod(0777, $dir);
|
||||
}
|
||||
}
|
||||
elsif ($self->{dir}) {
|
||||
$dir = $self->{dir};
|
||||
}
|
||||
|
||||
local *FILE;
|
||||
$self->{_error} = [];
|
||||
if (not $dir) {
|
||||
$self->error(NODIR => 'WARN');
|
||||
}
|
||||
elsif (not -d $dir or not -w $dir) {
|
||||
$self->error(BADDIR => WARN => $dir);
|
||||
}
|
||||
elsif (not $self->{file}) {
|
||||
$self->error(NOFILE => 'WARN');
|
||||
}
|
||||
elsif (-f "$dir/$self->{file}" and not -w _) {
|
||||
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
elsif (not open FILE, "> $dir/$self->{file}") {
|
||||
$self->error(SAVEERROR => WARN => "$dir/$self->{file}", "$!");
|
||||
}
|
||||
else { # Everything is good, now we have FILE open to the file.
|
||||
$self->debug("Saving $dir/$self->{file}");
|
||||
my $headers;
|
||||
while (my ($key, $val) = each %{$self->{headers}}) {
|
||||
next unless $key and $val;
|
||||
$key =~ s/\r?\n//g; $val =~ s/\r?\n//g; # Just in case...
|
||||
$headers .= "$key: $val\n";
|
||||
}
|
||||
print FILE $headers;
|
||||
print FILE "" . "\n"; # Blank line
|
||||
$self->{body} =~ s/\r\n/\n/g;
|
||||
print FILE $self->{body};
|
||||
close FILE;
|
||||
}
|
||||
|
||||
if (@{$self->{_error}}) {
|
||||
return { error => join("<br>\n", @{$self->{_error}}) };
|
||||
}
|
||||
else {
|
||||
return { success => 1, error => '' };
|
||||
}
|
||||
}
|
||||
|
||||
# GT::Mail::Editor::tpl_load(header => To, header => From, header => Subject)
|
||||
# In this case, "To", "From" and "Subject" will come to you as header_To,
|
||||
# header_From, and header_Subject.
|
||||
# What you get back is a hash reference, with either "error" set to an error
|
||||
# if something bad happened, or "success" set to 1, and the following template
|
||||
# variables:
|
||||
#
|
||||
# header_To, header_From, header_Subject, header_...
|
||||
# => The value of the To, From, Subject, etc. field.
|
||||
# -> Only present for individual headers that are requested with "header"
|
||||
# extra_headers => A loop of all the other headers with { name => To, From, etc., value => value }
|
||||
# body => The body of the e-mail. This will eventually change as this module
|
||||
# -> becomes capable of creating e-mails with multiple parts.
|
||||
sub tpl_load {
|
||||
my $self = &_get_self;
|
||||
my %sep_headers;
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (lc $_[$i] eq 'header') {
|
||||
$sep_headers{$_[++$i]} = 1;
|
||||
}
|
||||
}
|
||||
my $dir;
|
||||
if ($self->{dir} and $self->{template} and $self->{file}
|
||||
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
||||
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
||||
$dir = "$self->{dir}/$self->{template}";
|
||||
if (-f "$dir/local/$self->{file}") {
|
||||
$dir .= "/local";
|
||||
}
|
||||
elsif (!-f "$dir/$self->{file}") {
|
||||
my ($tplinfo, %tplinfo);
|
||||
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
||||
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
||||
$dir = $inherit;
|
||||
}
|
||||
else {
|
||||
$dir .= "/$inherit";
|
||||
}
|
||||
if (-f "$dir/local/$self->{file}") {
|
||||
$dir .= "/local";
|
||||
last;
|
||||
}
|
||||
elsif (-f "$dir/$self->{file}") {
|
||||
last;
|
||||
}
|
||||
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
||||
$self->error(RECURSION => WARN => $dir);
|
||||
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $fh = \do { local *FILE; *FILE };
|
||||
$self->{_error} = [];
|
||||
my $return = { success => 0, error => '' };
|
||||
if ($self->{template} =~ m[[\\/\x00-\x1f]] or $self->{template} eq '..') {
|
||||
$self->error(INVALIDDIR => WARN => $self->{template});
|
||||
}
|
||||
elsif ($self->{file} =~ m[[\\/\x00-\x1f]]) {
|
||||
$self->error(INVALIDTPL => WARN => $self->{file});
|
||||
}
|
||||
elsif (not $dir) {
|
||||
$self->error(NODIR => 'WARN');
|
||||
}
|
||||
elsif (not -d $dir) {
|
||||
$self->error(BADDIR => WARN => $dir);
|
||||
}
|
||||
elsif (not $self->{file}) {
|
||||
$self->error(NOFILE => 'WARN');
|
||||
}
|
||||
elsif (not -r "$dir/$self->{file}") {
|
||||
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
elsif (not open $fh, "< $dir/$self->{file}") {
|
||||
$self->error(LOADERROR => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
else { # Everything is good, now we have $fh open to the file.
|
||||
$return->{success} = 1;
|
||||
$self->load($fh);
|
||||
while (my ($name, $val) = each %{$self->{headers}}) {
|
||||
if ($sep_headers{$name}) {
|
||||
$return->{"header_$name"} = $val;
|
||||
}
|
||||
else {
|
||||
push @{$return->{extra_headers}}, { name => $name, value => $val };
|
||||
}
|
||||
}
|
||||
$return->{body} = $self->{body};
|
||||
}
|
||||
if ($self->{_error}) {
|
||||
$return->{error} = join "<br>\n", @{$self->{_error}};
|
||||
}
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub tpl_delete {
|
||||
my $self = &_get_self;
|
||||
|
||||
if ($self->{dir} and $self->{template} and $self->{file}
|
||||
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
||||
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
||||
my $tpl = "$self->{dir}/$self->{template}/local/$self->{file}";
|
||||
if (-f $tpl and not unlink $tpl) {
|
||||
return { error => "Unable to remove $tpl: $!" };
|
||||
}
|
||||
}
|
||||
return { success => 1, error => '' };
|
||||
}
|
||||
|
||||
# Loads a template from a filehandle or a file.
|
||||
# You must pass in a GLOB reference as a filehandle to be read from.
|
||||
# Otherwise, this method will attempt to open the file passed in and then read from it.
|
||||
# (the file opened will have directory and template prepended to it).
|
||||
sub load {
|
||||
my $self = shift;
|
||||
my $fh;
|
||||
my $file = shift;
|
||||
if (ref $file eq 'GLOB' or ref $file eq 'SCALAR' or ref $file eq 'LVALUE') {
|
||||
$fh = $file;
|
||||
}
|
||||
else {
|
||||
$fh = \do { local *FILE; *FILE };
|
||||
my $dir;
|
||||
if ($self->{template}) {
|
||||
$dir = "$self->{dir}/$self->{template}";
|
||||
if (-f "$dir/local/$file") {
|
||||
$dir .= "/local";
|
||||
}
|
||||
elsif (!-f "$dir/$file") {
|
||||
my ($tplinfo, %tplinfo);
|
||||
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
||||
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
||||
$dir = $inherit;
|
||||
}
|
||||
else {
|
||||
$dir .= "/$inherit";
|
||||
}
|
||||
if (-f "$dir/local/$file") {
|
||||
$dir .= "/local";
|
||||
last;
|
||||
}
|
||||
elsif (-f "$dir/$file") {
|
||||
last;
|
||||
}
|
||||
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
||||
$self->error(RECURSION => WARN => $dir);
|
||||
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$file = "$dir/$file";
|
||||
|
||||
open $fh, "< $file" or return $self->error(BADFILE => WARN => $file);
|
||||
}
|
||||
if (ref $fh eq 'GLOB') {
|
||||
while (<$fh>) { # The header
|
||||
s/\r?\n$//;
|
||||
last if not $_; # An empty line is the end of the headers
|
||||
my ($field, $value) = split /:\s*/, $_, 2;
|
||||
$self->{headers}->{$field} = $value;
|
||||
}
|
||||
while (<$fh>) { # The body
|
||||
$self->{body} .= $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
(my $header, $self->{body}) = split /\r?\n\r?\n/, $$fh, 2;
|
||||
my @h = split /\r?\n/, $header;
|
||||
for (@h) {
|
||||
my ($field, $value) = split /:\s*/, $_, 2;
|
||||
$self->{headers}->{$field} = $value;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Creates and returns a $self object. Looks at $_[0] to see if it is already
|
||||
# an editor object, and if so uses that. Otherwise it calls new() with @_.
|
||||
# Should be called as &_get_self; If called as a class method, the first
|
||||
# argument will be removed. So, instead of: 'my $self = shift;' you should
|
||||
# use: 'my $self = &_get_self;'
|
||||
sub _get_self {
|
||||
my $self;
|
||||
if (ref $_[0] and substr(ref $_[0], -8) eq '::Editor') { # This will allow any subclass as long as it is something::Editor
|
||||
$self = shift;
|
||||
}
|
||||
elsif (@_ and substr($_[0], -8) eq '::Editor') { # Class methods
|
||||
my $class = shift;
|
||||
$self = $class->new(@_);
|
||||
}
|
||||
else {
|
||||
$self = __PACKAGE__->new(@_);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->set(@_);
|
||||
tie %{$self->{headers}}, __PACKAGE__ . '::Ordered';
|
||||
}
|
||||
|
||||
|
||||
package GT::Mail::Editor::Ordered;
|
||||
# Implements a hash that retains the order elements are inserted into it.
|
||||
|
||||
sub TIEHASH { bless { o => [], h => {}, p => 0 }, $_[0] }
|
||||
|
||||
sub STORE {
|
||||
my ($self, $key, $val) = @_;
|
||||
$self->DELETE($key) if exists $self->{h}->{$key};
|
||||
$self->{h}->{$key} = $val;
|
||||
push @{$self->{o}}, $key;
|
||||
}
|
||||
|
||||
sub FETCH { $_[0]->{h}->{$_[1]} }
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
$self->{p} = 0;
|
||||
$self->{o}->[$self->{p}++]
|
||||
}
|
||||
|
||||
sub NEXTKEY { $_[0]->{o}->[$_[0]->{p}++] }
|
||||
|
||||
sub EXISTS { exists $_[0]->{h}->{$_[1]} }
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
for (0 .. $#{$self->{o}}) {
|
||||
if ($self->{o}->[$_] eq $key) {
|
||||
splice @{$self->{o}}, $_, 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
delete $self->{h}->{$key};
|
||||
}
|
||||
sub CLEAR { $_[0] = { o => [], h => {}, p => 0 }; () }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Editor - E-mail template editor
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Generally used from templates:
|
||||
|
||||
<%GT::Mail::Editor::tpl_load(
|
||||
dir => $template_root,
|
||||
template => $template_set,
|
||||
file => $filename,
|
||||
header => From,
|
||||
header => To,
|
||||
header => Subject
|
||||
)%>
|
||||
|
||||
<%if error%>
|
||||
Unable to load e-mail template: <%error%>
|
||||
<%else%>
|
||||
From: <input type=text name=header_From value="<%header_From%>">
|
||||
To: <input type=text name=header_To value="<%header_To%>">
|
||||
Subject: <input type=text name=header_Subject value="<%header_Subject%>">
|
||||
Other headers:<br>
|
||||
<textarea name=extra_headers>
|
||||
<%loop extra_headers%><%name%>: <%value%>
|
||||
<%endloop%>
|
||||
<%endif%>
|
||||
|
||||
|
||||
- or -
|
||||
|
||||
|
||||
<%GT::Mail::Editor::save(
|
||||
dir => $template_root,
|
||||
template => $template_set,
|
||||
file => $filename,
|
||||
header => To => $header_To,
|
||||
header => From => $header_From,
|
||||
header => Subject => $header_Subject,
|
||||
extra_headers => $extra_headers
|
||||
)%>
|
||||
<%if error%>Unable to save e-mail template: <%error%>
|
||||
... Display the above form in here ...
|
||||
<%endif%>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Editor is designed to provide a template interface to creating and
|
||||
editing a wide variety of e-mail templates. Although not currently supported,
|
||||
eventually attachments, HTML, etc. will be supported.
|
||||
|
||||
=head2 tpl_load - Loads a template (from the templates)
|
||||
|
||||
Calling GT::Mail::Editor::tpl_load from a template returns variables required to
|
||||
display a form to edit the template passed in.
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir
|
||||
|
||||
Defines the base directory of templates.
|
||||
|
||||
=item template
|
||||
|
||||
This defines a template set. This is optional. If present, this directory will
|
||||
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
||||
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
||||
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
||||
load e-mail templates.
|
||||
|
||||
=item file
|
||||
|
||||
Specify the filename of the template inside the directory already specified with
|
||||
'dir' and 'template'
|
||||
|
||||
=item header
|
||||
|
||||
Multiple "special" headers can be requested with this. The argument following
|
||||
each 'header' should be the name of a header, such as "To". Then, in the
|
||||
variables returned from tpl_load(), you will have a variable such as 'header_To'
|
||||
available, containing the value of the To: field.
|
||||
|
||||
=back
|
||||
|
||||
=head2 tpl_save - Save a template
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir template file
|
||||
|
||||
See the entries in L<"tpl_load">
|
||||
|
||||
=item header
|
||||
|
||||
Specifies that the two following arguments are the field and value of a header
|
||||
field. For example, header => To => "abc@example.com" would specify that the To
|
||||
field should be "abc@example.com" (To: abc@example.com).
|
||||
|
||||
=item extra_headers
|
||||
|
||||
The value to extra_headers should be a newline-delimited list of headers other
|
||||
than those specified with header. These will be parsed, and blank lines skipped.
|
||||
|
||||
=item body
|
||||
|
||||
The body of the message. Need I say more? MIME messages are possible by
|
||||
inserting them directly into the body, however currently MIME messages cannot
|
||||
be created using this editor.
|
||||
|
||||
=back
|
||||
|
||||
=head2 load
|
||||
|
||||
Attempts to load a GT::Mail::Editor object with data passed in. This can take
|
||||
either a file handle or a filename. If passing a filename, dir and template
|
||||
will be used (if available). You should construct an object with new() prior
|
||||
to calling this method.
|
||||
|
||||
=head2 new
|
||||
|
||||
Constructs a new GT::Mail::Editor object. This will be done automatically when
|
||||
using the template methods L<"tpl_load"> and L<"tpl_save">. Takes the following
|
||||
arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir
|
||||
|
||||
Defines the base directory of templates.
|
||||
|
||||
=item template
|
||||
|
||||
This defines a template set. This is optional. If present, this directory will
|
||||
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
||||
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
||||
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
||||
load e-mail templates.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Editor.pm,v 1.24 2005/01/18 23:06:40 bao Exp $
|
||||
|
||||
267
site/glist/lib/GT/Mail/Editor/HTML.pm
Normal file
267
site/glist/lib/GT/Mail/Editor/HTML.pm
Normal file
@ -0,0 +1,267 @@
|
||||
|
||||
package GT::Mail::Editor::HTML;
|
||||
|
||||
use vars qw/$ERROR_MESSAGE/;
|
||||
use strict;
|
||||
use bases 'GT::Mail::Editor' => '';
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Mail::Editor';
|
||||
|
||||
|
||||
sub display {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $tags ) = @_;
|
||||
my $page = $self->{html_tpl_name};
|
||||
|
||||
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
|
||||
$page = $self->{fields}{page};
|
||||
}
|
||||
my $ret = $self->print_page( $page, $tags );
|
||||
$self->{displayed} = 1;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub message_from_input {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->set_headers;
|
||||
|
||||
# If we have a part ID, this isn't a new text part
|
||||
my ( $part, $id );
|
||||
$part = $self->{part};
|
||||
$part->set( 'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
|
||||
if ( exists( $self->{fields}{msg} ) ) {
|
||||
my $msg = $self->{fields}{msg};
|
||||
$self->urls_to_inlines( $self->{part}, \$msg );
|
||||
$part->body_data( $msg );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_message {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Simple case if the message is not multipart
|
||||
if ( !$root_part->is_multipart ) {
|
||||
$self->munge_non_multipart( $root_part );
|
||||
}
|
||||
|
||||
# We have a multipart. First thing we do is look for an alternative part
|
||||
# to use.
|
||||
elsif ( my ( $alt ) = $self->{message}->find_multipart( 'alternative' ) ) {
|
||||
$self->munge_alternative( $alt );
|
||||
}
|
||||
else {
|
||||
$self->munge_other;
|
||||
}
|
||||
$self->fix_alt_parts;
|
||||
$self->fix_related_parts;
|
||||
$self->delete_empty_multiparts;
|
||||
my ( $alt_part ) = $self->{message}->find_multipart( 'alternative' );
|
||||
my @skip = $alt_part->parts;
|
||||
$self->find_attachments( @skip );
|
||||
$self->{alt_part} = $alt_part;
|
||||
$self->{part} = $skip[1];
|
||||
}
|
||||
|
||||
sub html_part {
|
||||
# ----------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{alt_part}->parts->[1];
|
||||
}
|
||||
|
||||
sub text_part {
|
||||
# ----------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{alt_part}->parts->[0];
|
||||
}
|
||||
|
||||
sub munge_non_multipart {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $root_part ) = @_;
|
||||
|
||||
# We need to munge the message into a multipart
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $root_part,
|
||||
charset => $root_part->mime_attr( 'content-type.charset' ),
|
||||
headers_part => $root_part
|
||||
);
|
||||
$root_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$root_part->parts( $new_alt );
|
||||
}
|
||||
|
||||
sub munge_alternative {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $alt_part ) = @_;
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Make anything we can not view an attachment
|
||||
$self->{message}->move_parts_last(
|
||||
$root_part,
|
||||
grep {
|
||||
$_->content_type ne 'text/plain' and $_->content_type ne 'text/html'
|
||||
} $alt_part->parts
|
||||
);
|
||||
|
||||
# Anything left is either text or html
|
||||
my ( $html_part, $text_part );
|
||||
for ( $alt_part->parts ) {
|
||||
if ( $_->content_type eq 'text/html' ) {
|
||||
$html_part = $_;
|
||||
}
|
||||
else {
|
||||
$text_part = $_;
|
||||
}
|
||||
}
|
||||
# If we do not have an editble part we need to make an empty html one
|
||||
if ( !defined( $text_part ) and !defined( $html_part ) ) {
|
||||
$html_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
|
||||
-body_data => '<html><body></body></html>'
|
||||
);
|
||||
}
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
if ( $alt_part == $root_part ) {
|
||||
$root_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$self->{message}->delete_parts( $root_part->parts );
|
||||
$root_part->parts( $new_alt );
|
||||
}
|
||||
else {
|
||||
$self->{message}->replace_part( $alt_part, $new_alt );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_other {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
# Else we need to search through the parts to find the displayable parts
|
||||
my ( $html_part, $text_part );
|
||||
for my $part ( $self->{message}->all_parts ) {
|
||||
if ( !$html_part and $part->content_type eq 'text/html' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
|
||||
$html_part = $part;
|
||||
}
|
||||
elsif ( !$text_part and $part->content_type eq 'text/plain' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
|
||||
$text_part = $part;
|
||||
}
|
||||
last if $html_part and $text_part;
|
||||
}
|
||||
# If we do not have an editble part we need to make an empty html one
|
||||
if ( !defined( $text_part ) and !defined( $html_part ) ) {
|
||||
$html_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
|
||||
-body_data => '<html><body></body></html>'
|
||||
);
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
|
||||
my $parent = $self->{message}->parent_part( $new_alt );
|
||||
if ( $parent and $parent->content_type eq 'multipart/related' ) {
|
||||
$parent->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
my $parent_part = $self->{message}->parent_part( $html_part );
|
||||
if ( !$parent_part ) { $parent_part = $self->{message}->parent_part( $text_part ) }
|
||||
if ( $parent_part and $parent_part->content_type eq 'multipart/related' ) {
|
||||
if ( !$html_part ) {
|
||||
$parent_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$self->{message}->add_parts_start( $parent_part, $new_alt );
|
||||
if ( $text_part ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{message}->replace_part( $parent_part->parts->[0], $new_alt );
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ( $text_part ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
}
|
||||
if ( $html_part ) {
|
||||
$self->{message}->delete_part( $html_part );
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub alt_part {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, %opts ) = @_;
|
||||
my ( $text, $html, $header_from, $charset ) = @opts{qw/text html headers_part charset/};
|
||||
|
||||
my $text_type = 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
|
||||
my $html_type = 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
|
||||
|
||||
if ( defined( $text ) ) {
|
||||
$text = $self->new_part_from( $text, $text_type );
|
||||
}
|
||||
elsif ( defined( $html ) ) {
|
||||
$text = $self->{message}->new_part(
|
||||
'content-type' => $text_type,
|
||||
-body_data => $self->html_to_text( ref( $html ) ? $html->body_data : $html )
|
||||
);
|
||||
}
|
||||
else {
|
||||
$self->fatal( BADARGS => "Either text or html must be defined" );
|
||||
}
|
||||
if ( defined( $html ) ) {
|
||||
$html = $self->new_part_from( $html, $html_type );
|
||||
}
|
||||
elsif ( defined( $text ) ) {
|
||||
$html = $self->{message}->new_part(
|
||||
'content-type' => $html_type,
|
||||
-body_data => $self->text_to_html( $text->body_data )
|
||||
);
|
||||
}
|
||||
# logic error, one must be defined
|
||||
else {
|
||||
$self->fatal( BADARGS => "Either text or html must be defined" );
|
||||
}
|
||||
my @header = ();
|
||||
if ( $header_from ) {
|
||||
@header = map { $_ => [$header_from->get( $_ )] } $header_from->get;
|
||||
}
|
||||
return $self->{message}->new_part(
|
||||
@header,
|
||||
'content-type' => 'multipart/alternative',
|
||||
-parts => [$text, $html]
|
||||
);
|
||||
}
|
||||
|
||||
sub new_part_from {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $from, $type ) = @_;
|
||||
if ( !ref( $from ) ) {
|
||||
return $self->{message}->new_part(
|
||||
'content-type' => $type,
|
||||
-body_data => $from
|
||||
);
|
||||
}
|
||||
elsif ( ref( $from ) ) {
|
||||
return $self->{message}->new_part(
|
||||
'content-type' => $type,
|
||||
-body_data => $from->body_data
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
147
site/glist/lib/GT/Mail/Editor/Text.pm
Normal file
147
site/glist/lib/GT/Mail/Editor/Text.pm
Normal file
@ -0,0 +1,147 @@
|
||||
|
||||
package GT::Mail::Editor::Text;
|
||||
|
||||
use vars qw/$ERROR_MESSAGE/;
|
||||
use strict;
|
||||
use bases 'GT::Mail::Editor' => '';
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Mail::Editor';
|
||||
|
||||
sub display {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $tags ) = @_;
|
||||
my $page = $self->{text_tpl_name};
|
||||
|
||||
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
|
||||
$page = $self->{fields}{page};
|
||||
}
|
||||
my $ret = $self->print_page( $page, $tags );
|
||||
$self->{displayed} = 1;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub message_from_input {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->set_headers;
|
||||
|
||||
# If we have a part ID, this isn't a new text part
|
||||
my ( $part, $id );
|
||||
$part = $self->{part};
|
||||
$part->set( 'content-type' => 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
|
||||
if ( exists( $self->{fields}{msg} ) ) {
|
||||
$part->body_data( $self->{fields}{msg} );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_message {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Simple case if the message is not multipart
|
||||
my ( $text_part, $html_part, $related_part, $alt_part );
|
||||
if ( !$root_part->is_multipart ) {
|
||||
$text_part = $root_part;
|
||||
}
|
||||
|
||||
# We have a multipart. First thing we do is look for an alternative part
|
||||
# to use.
|
||||
else {
|
||||
|
||||
# First we look for the proper alternative mime parts
|
||||
$alt_part = ($self->{message}->find_multipart( 'alternative' ))[0];
|
||||
if ( $alt_part ) {
|
||||
my @alt_parts = $alt_part->parts;
|
||||
for ( @alt_parts ) {
|
||||
if ( $_->content_type eq 'text/plain' ) {
|
||||
$text_part = $self->{message}->delete_part( $_ );
|
||||
}
|
||||
elsif ( $_->content_type eq 'text/html' ) {
|
||||
$html_part = $self->{message}->delete_part( $_ );
|
||||
}
|
||||
}
|
||||
if ( !$text_part and $html_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => $self->html_to_text( $html_part->body_data )
|
||||
);
|
||||
}
|
||||
elsif ( !$text_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => ''
|
||||
);
|
||||
}
|
||||
|
||||
# Make anything we can not view an attachment
|
||||
$self->{message}->move_parts_last(
|
||||
$root_part,
|
||||
map {
|
||||
unless ( $_->is_multipart ) {
|
||||
$_->set( 'content-disposition' => 'attachment' );
|
||||
}
|
||||
$_;
|
||||
} $alt_part->parts
|
||||
);
|
||||
|
||||
if ( $alt_part == $root_part ) {
|
||||
$alt_part->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
else {
|
||||
$self->{message}->delete_part( $alt_part );
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
|
||||
}
|
||||
else {
|
||||
|
||||
# Else we can just stick the text part at the beginning
|
||||
for my $part ( $self->{message}->all_parts ) {
|
||||
my $disp = $part->mime_attr( 'content-disposition' );
|
||||
next if $disp and $disp eq 'attachment';
|
||||
if ( $part->content_type eq 'text/plain' ) {
|
||||
$text_part = $self->{message}->delete_part( $part );
|
||||
}
|
||||
elsif ( $part->content_type eq 'text/html' ) {
|
||||
$html_part = $self->{message}->delete_part( $part );
|
||||
}
|
||||
}
|
||||
if ( !$text_part and $html_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => $self->html_to_text( $html_part->body_data )
|
||||
);
|
||||
}
|
||||
elsif ( !$text_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => ''
|
||||
);
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
|
||||
}
|
||||
}
|
||||
my $parent = $self->{message}->parent_part( $text_part );
|
||||
if ( $parent and $parent->content_type eq 'multipart/related' ) {
|
||||
$parent->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
$self->fix_alt_parts;
|
||||
$self->fix_related_parts;
|
||||
$self->delete_empty_multiparts;
|
||||
$self->find_attachments( $text_part );
|
||||
|
||||
if ( @{[$self->{message}->all_parts]} == 1 and $self->{message}->root_part->is_multipart ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
my $root_part = $self->{message}->root_part;
|
||||
$root_part->set( 'content-type' => 'text/plain' );
|
||||
$root_part->body_data( $text_part->body_data );
|
||||
}
|
||||
$self->{part} = $text_part;
|
||||
}
|
||||
|
||||
sub html_part { return }
|
||||
sub text_part { return shift()->{part} }
|
||||
|
||||
1;
|
||||
|
||||
429
site/glist/lib/GT/Mail/Encoder.pm
Normal file
429
site/glist/lib/GT/Mail/Encoder.pm
Normal file
@ -0,0 +1,429 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Encoder
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Encoder.pm,v 1.40 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface for encoding data.
|
||||
#
|
||||
|
||||
package GT::Mail::Encoder;
|
||||
# ==================================================================
|
||||
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04
|
||||
# wipes our ISA.
|
||||
my $have_b64 = eval {
|
||||
local $SIG{__DIE__};
|
||||
require MIME::Base64;
|
||||
import MIME::Base64;
|
||||
if ($] < 5.005) { local $^W; encode_base64('brok'); }
|
||||
1;
|
||||
};
|
||||
$have_b64 or *encode_base64 = \>_old_encode_base64;
|
||||
my $use_encode_qp;
|
||||
if ($have_b64 and
|
||||
$MIME::Base64::VERSION >= 2.16 and
|
||||
defined &MIME::QuotedPrint::encode_qp and (
|
||||
not defined &MIME::QuotedPrint::old_encode_qp or
|
||||
\&MIME::QuotedPrint::encode_qp != \&MIME::QuotedPrint::old_encode_qp
|
||||
)
|
||||
) {
|
||||
$use_encode_qp = 1;
|
||||
}
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG @ISA %EncodeFor $CRLF);
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.40 $ =~ /(\d+)\.(\d+)/;
|
||||
$CRLF = "\015\012";
|
||||
$DEBUG = 0;
|
||||
@ISA = qw(GT::Base);
|
||||
|
||||
my %EncoderFor = (
|
||||
# Standard...
|
||||
'7bit' => sub { NBit('7bit', @_) },
|
||||
'8bit' => sub { NBit('8bit', @_) },
|
||||
'base64' => \&Base64,
|
||||
'binary' => \&Binary,
|
||||
'none' => \&Binary,
|
||||
'quoted-printable' => \&QuotedPrint,
|
||||
|
||||
# Non-standard...
|
||||
'x-uu' => \&UU,
|
||||
'x-uuencode' => \&UU,
|
||||
);
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------------------------
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
$self->init(@_);
|
||||
my $encoding = lc($self->{encoding} || '');
|
||||
defined $EncoderFor{$encoding} or return or return $self->error("NOENCODING", "FATAL");
|
||||
$self->debug("Set encoding to $encoding") if ($self->{_debug});
|
||||
$self->{encoding} = $EncoderFor{$encoding};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->init (%opts);
|
||||
# -------------------
|
||||
# Sets the options for the current object.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
else { return $self->error("BADARGS", "FATAL", "init") }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
|
||||
for my $m (qw(encoding in out)) {
|
||||
$self->{$m} = $opt->{$m} if defined $opt->{$m};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub gt_encode {
|
||||
# --------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (!ref $self or ref $self ne 'GT::Mail::Encoder') {
|
||||
$self = GT::Mail::Encoder->new(@_) or return;
|
||||
}
|
||||
$self->{encoding} or return $self->error("NOENCODING", "FATAL");;
|
||||
return $self->{encoding}->($self->{in}, $self->{out});
|
||||
}
|
||||
|
||||
sub supported { return exists $EncoderFor{pop()} }
|
||||
|
||||
|
||||
sub Base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
my $encoded;
|
||||
|
||||
my $nread;
|
||||
my $buf = '';
|
||||
|
||||
# Reading multiples of 57 bytes is recommended by MIME::Base64 as it comes out
|
||||
# to a line of exactly 76 characters (the max). We use 2299*57 (131043 bytes)
|
||||
# because it comes out to about 128KB (131072 bytes). Admittedly, this number
|
||||
# is fairly arbitrary, but should work well for both large and small files, and
|
||||
# shouldn't be too memory intensive.
|
||||
my $read_size = 2299 * 57;
|
||||
|
||||
if (not ref $in) {
|
||||
while (1) {
|
||||
last unless length $in;
|
||||
$buf = substr($in, 0, $read_size);
|
||||
substr($in, 0, $read_size) = '';
|
||||
|
||||
$encoded = encode_base64($buf, $CRLF);
|
||||
|
||||
# Encoding to send over SMTP
|
||||
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
|
||||
$out->($encoded);
|
||||
}
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
while ($nread = read($in, $buf, $read_size)) {
|
||||
$encoded = encode_base64($buf, $CRLF);
|
||||
|
||||
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
|
||||
$out->($encoded);
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to Base64, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub Binary {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
|
||||
if (not ref $in) {
|
||||
$in =~ s/\015?\012/$CRLF/g;
|
||||
$out->($in);
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
my ($buf, $nread) = ('', 0);
|
||||
while ($nread = read($in, $buf, 4096)) {
|
||||
$buf =~ s/\015?\012/$CRLF/g;
|
||||
$out->($buf);
|
||||
}
|
||||
defined ($nread) or return; # check for error
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to Binary, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub UU {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out, $file) = @_;
|
||||
|
||||
my $buf = '';
|
||||
my $fname = ($file || '');
|
||||
$out->("begin 644 $fname\n");
|
||||
if (not ref $in) {
|
||||
while (1) {
|
||||
last unless length $in;
|
||||
$buf = substr($in, 0, 45);
|
||||
substr($in, 0, 45) = '';
|
||||
$out->(pack('u', $buf));
|
||||
}
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
while (read($in, $buf, 45)) {
|
||||
$buf =~ s/\015?\012/$CRLF/g;
|
||||
$out->(pack('u', $buf))
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to UU, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
$out->("end\n");
|
||||
1;
|
||||
}
|
||||
|
||||
sub NBit {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($enc, $in, $out) = @_;
|
||||
|
||||
if (not ref $in) {
|
||||
$in =~ s/\015?\012/$CRLF/g;
|
||||
$out->($in);
|
||||
}
|
||||
elsif (fileno $in) {
|
||||
while (<$in>) {
|
||||
s/\015?\012/$CRLF/g;
|
||||
$out->($_);
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to NBit, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub QuotedPrint {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
|
||||
local $_;
|
||||
my $ref = ref $in;
|
||||
if ($ref and !fileno($in)) {
|
||||
if ($ref eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to QuotedPrint, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
}
|
||||
$in =~ s/\015?\012/\n/g unless $ref;
|
||||
|
||||
while () {
|
||||
local $_;
|
||||
if ($ref) {
|
||||
# Try to get around 32KB at once. This could end up being much larger than
|
||||
# 32KB if there is a very very long line - up to the length of the line + 32700
|
||||
# bytes.
|
||||
$_ = <$in>;
|
||||
while (my $line = <$in>) {
|
||||
$_ .= $line;
|
||||
last if length > 32_700; # Not exactly 32KB, but close enough.
|
||||
}
|
||||
last unless defined;
|
||||
}
|
||||
else {
|
||||
# Grab up to just shy of 32KB of the string, plus the following line. As
|
||||
# above, this could be much longer than 32KB if there is one or more very long
|
||||
# lines involved.
|
||||
$in =~ s/^(.{0,32700}.*?(?:\n|\Z))//ms; # Encode somewhere around 32KB at a time
|
||||
$_ = $1;
|
||||
last unless defined and length;
|
||||
}
|
||||
|
||||
if ($use_encode_qp) {
|
||||
$_ = MIME::QuotedPrint::encode_qp($_, $CRLF);
|
||||
}
|
||||
else {
|
||||
s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
|
||||
s/([ \t]+)$/
|
||||
join('', map { sprintf("=%02X", ord($_)) }
|
||||
split('', $1)
|
||||
)/egm; # rule #3 (encode whitespace at eol)
|
||||
|
||||
# rule #5 (lines must be shorter than 76 chars, but we are not allowed
|
||||
# to break =XX escapes. This makes things complicated :-( )
|
||||
my $brokenlines = "";
|
||||
$brokenlines .= "$1=\n"
|
||||
while s/(.*?^[^\n]{73} (?:
|
||||
[^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
|
||||
|[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
|
||||
| (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
|
||||
))//xsm;
|
||||
|
||||
$_ = "$brokenlines$_";
|
||||
|
||||
s/\015?\012/$CRLF/g;
|
||||
}
|
||||
|
||||
# Escape 'From ' at the beginning of the line. This is fairly easy - if the
|
||||
# line is currently 73 or fewer characters, we simply change the F to =46,
|
||||
# making the line 75 characters long (the max). If the line is longer than 73,
|
||||
# we escape the F, follow it with "=$CRLF", and put the 'rom ' and the rest of
|
||||
# the line on the next line - meaning one line of 4 characters, and one of 73
|
||||
# or 74.
|
||||
s/^From (.*)/
|
||||
length($1) <= 68 ? "=46rom $1" : "=46=${CRLF}rom $1"
|
||||
/emg; # Escape 'From' at the beginning of a line
|
||||
# The '.' at the beginning of the line is more difficult. The easy case is
|
||||
# when the line is 73 or fewer characters - just escape the initial . and we're
|
||||
# done. If the line is longer, the fun starts. First, we escape the initial .
|
||||
# to =2E. Then we look for the first = in the line; if it is found within the
|
||||
# first 3 characters, we split two characters after it (to catch the "12" in
|
||||
# "=12") otherwise we split after the third character. We then add "=$CRLF" to
|
||||
# the current line, and look at the next line; if it starts with 'From ' or a
|
||||
# ., we escape it - and since the second line will always be less than 73
|
||||
# characters long (since we remove at least three for the first line), we can
|
||||
# just escape it without worrying about splitting the line up again.
|
||||
s/^\.([^$CRLF]*)/
|
||||
if (length($1) <= 72) {
|
||||
"=2E$1"
|
||||
}
|
||||
else {
|
||||
my $ret = "=2E";
|
||||
my $match = $1;
|
||||
my $index = index($match, '=');
|
||||
my $len = $index >= 2 ? 2 : $index + 3;
|
||||
$ret .= substr($match, 0, $len);
|
||||
substr($match, 0, $len) = '';
|
||||
$ret .= "=$CRLF";
|
||||
substr($match, 0, 1) = "=46" if substr($match, 0, 5) eq 'From ';
|
||||
substr($match, 0, 1) = "=2E" if substr($match, 0, 1) eq '.';
|
||||
$ret .= $match;
|
||||
$ret
|
||||
}
|
||||
/emg;
|
||||
|
||||
$out->($_);
|
||||
|
||||
last unless $ref or length $in;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub gt_old_encode_base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $eol = $_[1];
|
||||
$eol = "\n" unless defined $eol;
|
||||
|
||||
my $res = pack("u", $_[0]);
|
||||
$res =~ s/^.//mg; # Remove first character of each line
|
||||
$res =~ tr/\n//d; # Remove newlines
|
||||
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;
|
||||
|
||||
# Fix padding at the end
|
||||
my $padding = (3 - length($_[0]) % 3) % 3;
|
||||
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
|
||||
|
||||
# Break encoded string into lines of no more than 76 characters each
|
||||
if (length $eol) {
|
||||
$res =~ s/(.{1,76})/$1$eol/g;
|
||||
}
|
||||
$res;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Encoder - MIME Encoder
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
open IN, 'decoded.txt' or die $!;
|
||||
open OUT, '>encoded.txt' or die $!;
|
||||
if (GT::Mail::Encoder->supported ('7bit')) {
|
||||
GT::Mail::Encoder->decode (
|
||||
debug => 1,
|
||||
encoding => '7bit',
|
||||
in => \*IN,
|
||||
out => sub { print OUT $_[0] }
|
||||
) or die $GT::Mail::Encoder::error;
|
||||
}
|
||||
else {
|
||||
die "Unsupported encoding";
|
||||
}
|
||||
close IN;
|
||||
close OUT;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Encoder is a MIME Encoder implemented in perl. It will try to use
|
||||
the C extension for encoding Base64. If the extension is not there
|
||||
it will do it in perl (slow!).
|
||||
|
||||
=head2 Encoding a stream
|
||||
|
||||
The new() constructor and the supported() class method are the only methods that
|
||||
are public in the interface. The new() constructor takes a hash of params.
|
||||
The supported() method takes a single string, the name of the encoding you want
|
||||
to encode and returns true if the encoding is supported and false otherwise.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Set debugging level. 1 or 0.
|
||||
|
||||
=item encoding
|
||||
|
||||
Sets the encoding used to encode.
|
||||
|
||||
=item in
|
||||
|
||||
Set to a file handle or IO handle.
|
||||
|
||||
=item out
|
||||
|
||||
Set to a code reference, the decoded stream will be passed in at the first
|
||||
argument for each chunk encoded.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Encoder.pm,v 1.40 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
|
||||
672
site/glist/lib/GT/Mail/Message.pm
Normal file
672
site/glist/lib/GT/Mail/Message.pm
Normal file
@ -0,0 +1,672 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Message
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::Mail::Message;
|
||||
|
||||
use strict;
|
||||
use vars qw/$ATTRIBS $CRLF/;
|
||||
use bases 'GT::Base' => '';
|
||||
|
||||
$ATTRIBS = {
|
||||
root_part => undef,
|
||||
debug => 0
|
||||
};
|
||||
|
||||
$CRLF = "\012";
|
||||
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# Init called from GT::Base
|
||||
my $self = shift;
|
||||
|
||||
$self->set( @_ );
|
||||
|
||||
if ( !defined( $self->{root_part} ) ) {
|
||||
$self->{root_part} = new GT::Mail::Parts;
|
||||
}
|
||||
$self->{parts} = _get_parts( $self->{root_part} );
|
||||
}
|
||||
|
||||
|
||||
sub delete_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Deletes the given part from the email
|
||||
#
|
||||
my ( $self, $part ) = @_;
|
||||
|
||||
die "Can't delete top level part" if $part == $self->{root_part};
|
||||
$self->_link;
|
||||
|
||||
|
||||
# We must remove it from the flat list of parts
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we must relink our list
|
||||
$self->_link;
|
||||
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub move_part_before {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part before another part. The first argument is the part to move
|
||||
# before, the second is the part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $before_part, $part ) = @_;
|
||||
die "Can't move part before the top part" if $before_part == $self->{root_part};
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $before_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we add
|
||||
$self->add_part_before( $before_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_after {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part after another part. The first argument is the part to move
|
||||
# after, the second is the part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $after_part, $part ) = @_;
|
||||
die "Can't move part after the top part" if $after_part == $self->{root_part};
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $after_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we add
|
||||
$self->add_part_after( $after_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_end {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to the end of a multipart part. The first part is the
|
||||
# multipart part to move it to the end of. The second argument is the part
|
||||
# to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part to be moved
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Then we add it back in
|
||||
$self->add_part_end( $parent_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_beginning {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to the beginning of a multipart part. The first part is the
|
||||
# multipart part to move it to the beginning of. The second argument is the
|
||||
# part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part to be moved
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Then we add it back in
|
||||
$self->add_part_beginning( $parent_part, $part );
|
||||
}
|
||||
|
||||
sub replace_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Replace a part with another part
|
||||
#
|
||||
my ( $self, $old_part, $new_part ) = @_;
|
||||
$self->_link;
|
||||
splice( @{$self->{parts}}, $old_part->{id}, 1, $new_part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_before {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part before the given part. The first argument is the part object
|
||||
# to add the part before. the second argument is the part to add.
|
||||
#
|
||||
my ( $self, $before_part, $part ) = @_;
|
||||
$self->_link;
|
||||
die "Can't add part before the top level part" if $before_part == $self->{root_part};
|
||||
my $parent_id = $before_part->{parent_id};
|
||||
|
||||
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The part's parent must exist and must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $before_part->{id}, 0, $part );
|
||||
my $parent_part = $self->{parts}[$parent_id];
|
||||
$parent_part->add_parts_before( $before_part->{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_after {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part after the given part. The first argument is the part object
|
||||
# to add the part after. the second argument is the part to add.
|
||||
#
|
||||
my ( $self, $after_part, $part ) = @_;
|
||||
$self->_link;
|
||||
die "Can't add part after the top level part" if $after_part == $self->{root_part};
|
||||
my $parent_id = $after_part->{parent_id};
|
||||
|
||||
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The part's parent must exist and must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $after_part->{id} + 1, 0, $part );
|
||||
my $parent_part = $self->{parts}[$parent_id];
|
||||
$parent_part->add_parts_after( $after_part->{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_beginning {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part at the beginning of the given multipart part. The first
|
||||
# argument is the part object to add the part before. the second argument is
|
||||
# the part to add.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + 1, 0, $part );
|
||||
$parent_part->add_part_before( $part->{parts}[0]{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_end {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part at the end of the given multipart part. The first argument is
|
||||
# the part object to add the part at the end of. the second argument is the
|
||||
# part to add. The first argument must be a multipart part or a fatal error
|
||||
# occurs.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + @parts, 0, $part );
|
||||
$parent_part->parts( $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub move_part_to_position {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to a position within another multipart part. The first
|
||||
# argument is the part to move within, the second argument is the part to
|
||||
# move and the final argument is the position within those parts to move it
|
||||
# in.
|
||||
#
|
||||
my ( $self, $parent_part, $part, $pos ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + $pos, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub get_part_by_id {
|
||||
# --------------------------------------------------------------------------
|
||||
# Method to retrieve a part object by it's id
|
||||
#
|
||||
my ( $self, $id ) = @_;
|
||||
|
||||
return $self->{parts}[$id];
|
||||
}
|
||||
|
||||
sub new_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Method to easily create a part object. All the header fields can be passed
|
||||
# in as a hash. If the key "body_data" the value will be set as the parts
|
||||
# body rather than a header field.
|
||||
#
|
||||
my ( $self, @opts ) = @_;
|
||||
my $part = new GT::Mail::Parts;
|
||||
while ( my ( $key, $val ) = ( shift( @opts ), shift( @opts ) ) ) {
|
||||
if ( $key eq 'body_data' ) {
|
||||
$part->body_data( $val );
|
||||
}
|
||||
elsif ( $key eq 'body_handle' ) {
|
||||
$part->body_handle( $val );
|
||||
}
|
||||
elsif ( $key eq 'body_path' ) {
|
||||
$part->body_path( $val );
|
||||
}
|
||||
else {
|
||||
$part->set( $key => $val );
|
||||
}
|
||||
}
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub all_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# my @parts = $obj->all_parts;
|
||||
# ----------------------------
|
||||
# Returns a list of all the part object for the current parsed email.
|
||||
# If the email is not multipart this will be just the header part.
|
||||
#
|
||||
return @{shift()->{parts}}
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------------------------
|
||||
# Returns the total size of an email. Call this method after the email has
|
||||
# been parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
(@{$self->{parts}} > 0) or return;
|
||||
my $size = 0;
|
||||
foreach (@{$self->{parts}}) {
|
||||
$size += $_->size;
|
||||
}
|
||||
return $size;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
# --------------------------------------------------------------------------
|
||||
# Returns the entire email as a sting.
|
||||
#
|
||||
my ( $self ) = @_;
|
||||
$GT::Mail::Encoder::CRLF = $CRLF;
|
||||
|
||||
my $out;
|
||||
$$out = ' ' x 50*1024;
|
||||
$self->debug ("\n\t--------------> Creating email") if $self->{_debug};
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{root_part} or die "No root part!";
|
||||
$self->{root_part}->set( 'MIME-Version' => '1.0' ) unless $self->{root_part}->get( 'MIME-Version' );
|
||||
|
||||
my $bound = $self->{root_part}->multipart_boundary;
|
||||
|
||||
# If the message has parts
|
||||
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
$self->debug( "Creating multipart email." ) if $self->{_debug};
|
||||
$self->_build_multipart_head( $out );
|
||||
}
|
||||
|
||||
# Else we are single part and have either a body IO handle or the body is in memory
|
||||
else {
|
||||
$self->debug( "Creating singlepart email." ) if $self->{_debug};
|
||||
$self->_build_singlepart_head( $out );
|
||||
}
|
||||
|
||||
# If we have parts go through all of them and add them.
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
my $num_parts = $#{$self->{root_part}->{parts}};
|
||||
for my $num ( 0 .. $num_parts ) {
|
||||
next unless $self->{root_part}->{parts}->[$num];
|
||||
$self->debug( "Creating part ($num)." ) if $self->{_debug};
|
||||
$self->_build_parts( $out, $self->{root_part}->{parts}->[$num] );
|
||||
if ( $num_parts == $num ) {
|
||||
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Add the epilogue if we are multipart
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
my $epilogue = join( '', @{$self->{root_part}->epilogue || []} ) || '';
|
||||
$epilogue =~ s/\015?\012//g;
|
||||
$self->debug( "Setting epilogue to ($epilogue)" ) if $self->{_debug};
|
||||
$$out .= $epilogue . $CRLF . $CRLF if $epilogue;
|
||||
}
|
||||
$self->debug( "\n\t<-------------- Email created." ) if $self->{_debug};
|
||||
return $$out;
|
||||
}
|
||||
|
||||
sub _build_multipart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a multipart header.
|
||||
#
|
||||
my ( $self, $out ) = @_;
|
||||
my $bound = $self->{root_part}->multipart_boundary;
|
||||
my $encoding = $self->{root_part}->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if ( $self->{debug} );
|
||||
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
$bound or $bound = "---------=_" . scalar (time) . "-$$-" . int(rand(time)/2);
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $self->{root_part}->get( 'Content-Type' );
|
||||
if ( $c !~ /\Q$bound/i ) {
|
||||
if ( $c and lc( $c ) !~ /boundary=/ ) {
|
||||
$c =~ /multipart/ or $c = 'multipart/mixed';
|
||||
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{debug};
|
||||
$self->{root_part}->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
|
||||
$self->{root_part}->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! )
|
||||
}
|
||||
}
|
||||
|
||||
my $preamble = join( '', @{$self->{root_part}->preamble || []} ) || "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug( "Setting preamble to ($preamble)." ) if ( $self->{_debug} );
|
||||
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_singlepart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a single part header.
|
||||
#
|
||||
my ( $self, $out ) = @_;
|
||||
my $encoding = $self->{root_part}->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
|
||||
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$$out .= $head . $CRLF;
|
||||
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode (
|
||||
debug => $self->{_debug},
|
||||
encoding => $encoding,
|
||||
in => $self->{root_part}->body_as_string,
|
||||
out => $out
|
||||
) or return;
|
||||
|
||||
# Must seek to the beginning for additional calles
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method that builds the parts for the email.
|
||||
#
|
||||
my ($self, $out, $part) = @_;
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{root_part} or die "No root part!";
|
||||
|
||||
my ( $body, $encoding, $bound );
|
||||
$bound = $part->multipart_boundary;
|
||||
|
||||
|
||||
# Find the encoding for the part and set it.
|
||||
$encoding = $part->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
|
||||
$part->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
|
||||
# If the message has parts and has a multipart boundary
|
||||
if ( @{$part->{parts}} > 0 and $bound ) {
|
||||
$self->debug( "Part is multpart." ) if $self->{_debug};
|
||||
|
||||
# Set the multipart boundary
|
||||
$self->debug( "Setting boundary to ($bound)." ) if $self->{_debug};
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $part->get( 'Content-Type' );
|
||||
if ( $c ) {
|
||||
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{_debug};
|
||||
$part->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
|
||||
$part->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! );
|
||||
}
|
||||
|
||||
my $preamble = join( '' => @{ $part->preamble || [] } ) || "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug( "Setting preamble to ($preamble)." ) if $self->{_debug};
|
||||
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $head . $CRLF . $preamble . $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Part is single part." ) if $self->{_debug};
|
||||
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$$out .= $head . $CRLF;
|
||||
|
||||
# Set the body only if we have one. We would not have one on the head an multipart
|
||||
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
encoding => $encoding,
|
||||
debug => $self->{_debug},
|
||||
in => $part->body_as_string,
|
||||
out => $out
|
||||
) or return;
|
||||
|
||||
}
|
||||
|
||||
# Add the rest of the parts
|
||||
if ( @{$part->{parts}} > 0 ) {
|
||||
$self->debug( "Part has parts." ) if $self->{_debug};
|
||||
my $num_parts = $#{$part->{parts}};
|
||||
for my $num ( 0 .. $num_parts ) {
|
||||
next unless $part->{parts}->[$num];
|
||||
$self->debug( "Creating part ($num)." ) if $self->{_debug};
|
||||
$self->_build_parts( $out, $part->{parts}->[$num] ) or return;
|
||||
if ( $bound ) {
|
||||
if ( $num_parts == $num ) {
|
||||
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Maybe done!
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _delete_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal method to delete a part
|
||||
my ( $self, $part ) = @_;
|
||||
|
||||
# We must remove it from it's parent
|
||||
my $parent = $self->{parts}[$part->{parent_id}];
|
||||
for ( 0 .. $#{$parent->{parts}} ) {
|
||||
if ( $parent->{parts}[$_]{id} == $part->{id} ) {
|
||||
splice( @{$parent->{parts}}, $_, 1 );
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# We must remove it from the flat list of parts
|
||||
return splice( @{$self->{parts}}, $part->{id}, 1 );
|
||||
}
|
||||
|
||||
sub _part_in_message {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal method to find out weather a part is in the current message
|
||||
my ( $self, $part ) = @_;
|
||||
for ( @{$self->{parts}} ) {
|
||||
return 1 if $_ == $part;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _link {
|
||||
# --------------------------------------------------------------------------
|
||||
# Creats part ids and links the children to the parrents. Called
|
||||
# When parts arer modified
|
||||
#
|
||||
my ( $self ) = @_;
|
||||
|
||||
# Creates ids to keep track of parts with.
|
||||
for ( 0 .. $#{$self->{parts}} ) {
|
||||
$self->{parts}[$_]{id} = $_;
|
||||
}
|
||||
_link_ids( $self->{root_part} );
|
||||
}
|
||||
|
||||
sub _links_ids {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal function to link all children to their parents with the parent id.
|
||||
# RECURSIVE
|
||||
#
|
||||
my ( $part, $parent_id ) = @_;
|
||||
for ( @{$part->{parts}} ) {
|
||||
_link_ids( $_, $part->{id} );
|
||||
}
|
||||
$part->{parent_id} = $parent_id;
|
||||
}
|
||||
|
||||
sub _get_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Recursive function to get a flat list of all the parts in a part structure
|
||||
#
|
||||
my ( $part, $parts ) = @_;
|
||||
$parts ||= [];
|
||||
|
||||
for ( @{$part->{parts}} ) {
|
||||
push @$parts, @{_get_parts( $_, $parts )};
|
||||
}
|
||||
return $parts;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Message - Encapsolates an email message.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Message;
|
||||
|
||||
# Get a GT::Mail::Message object from the parser
|
||||
use GT::Mail::Parse;
|
||||
|
||||
my $parser = new GT::Mail::Parse( in_file => "myemail.eml" );
|
||||
my $message = $parser->parse;
|
||||
|
||||
# Get the top level part
|
||||
my $root_part = $message->root_part;
|
||||
|
||||
# Replace the first part with a new part
|
||||
$message->replace_part( $root_part, $message->new_part(
|
||||
to => 'scott@gossamer-threads.com',
|
||||
from => 'alex@gossamer-threads.com',
|
||||
'content-type' => 'text/plain',
|
||||
body_data => 'Hi Scott, how are you?!'
|
||||
);
|
||||
|
||||
# Add a part at the end
|
||||
my $end_part = $message->new_part(
|
||||
'content-type' => 'image/gif',
|
||||
body_path => 'myimage.jpg'
|
||||
);
|
||||
$message->add_part_end( $root_part, $end_part );
|
||||
|
||||
# Move the first part in the top part to after the end part
|
||||
$message->move_part_after( $root_part->parts->[0], $end_part );
|
||||
|
||||
# Print the mime message
|
||||
print $message->to_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Message encapsolates a mime message which consists of
|
||||
L<GT::Mail::Parts> object. This module provides methods to change,
|
||||
move, remove, and access these parts.
|
||||
|
||||
=head2 Creating a new GT::Mail::Message object
|
||||
|
||||
Usually you will get a GT::Mail::Message object by call the parse method
|
||||
in L<GT::Mail::Parse>.
|
||||
|
||||
my $message = $parser->parse;
|
||||
|
||||
You may also call new on this class specifying the top level part and or
|
||||
a debug level.
|
||||
|
||||
my $message = new GT::Mail::Message(
|
||||
root_part => $part,
|
||||
debug => 1
|
||||
);
|
||||
|
||||
=head2 Creating a new Part
|
||||
|
||||
You can create a part by calling new on L<GT::Mail::Parts> directly
|
||||
|
||||
my $part = new GT::Mail::Parts;
|
||||
$part->set( 'content-type' => 'image/gif' );
|
||||
$part->body_path( 'myimage.gif' );
|
||||
|
||||
or you can call a method in this module to get a new part
|
||||
|
||||
my $part = $message->new_part(
|
||||
'content-type' => 'image/gif',
|
||||
body_path => 'myimage.gif'
|
||||
);
|
||||
|
||||
This method is a wraper on a combination of new() and some other
|
||||
supporting methods in L<GT::Mail::Parts> such as body_path(). Anything
|
||||
that is not B<body_path>, B<body_data>, or B<body_handle> is treated
|
||||
as header values.
|
||||
|
||||
=head2 Manipulating Parts
|
||||
|
||||
A MIME message is just a format for storing a tree structure. We provide
|
||||
tree-like methods to manipulate parts. All the method for manipulating
|
||||
parts take the part object(s) as arguments. We do this so you do not need
|
||||
to know how the tree is tracked internally.
|
||||
|
||||
=head2 Accessing Parts
|
||||
|
||||
|
||||
More to come!
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
|
||||
|
||||
829
site/glist/lib/GT/Mail/POP3.pm
Normal file
829
site/glist/lib/GT/Mail/POP3.pm
Normal file
@ -0,0 +1,829 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::POP3
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: POP3.pm,v 1.56 2004/03/19 00:36:16 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to a POP3 server.
|
||||
#
|
||||
|
||||
package GT::Mail::POP3;
|
||||
# ==================================================================
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw!$VERSION $DEBUG $ERROR $CRLF @ISA $ERRORS $ATTRIBS!;
|
||||
|
||||
# Constants
|
||||
use constants TIMEOUT => 0.01; # The timeout used on selects.
|
||||
|
||||
# Internal modules
|
||||
use GT::Base;
|
||||
use GT::Socket::Client;
|
||||
use GT::Mail::Parts;
|
||||
use GT::Mail::Parse;
|
||||
|
||||
# System modules
|
||||
use Fcntl qw/O_NONBLOCK F_SETFL F_GETFL/;
|
||||
use POSIX qw/EAGAIN EINTR/;
|
||||
|
||||
# Silence warnings
|
||||
$GT::Mail::Parse::error = '';
|
||||
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$CRLF = "\r\n";
|
||||
$| = 1;
|
||||
|
||||
$ATTRIBS = {
|
||||
host => undef,
|
||||
port => undef,
|
||||
user => undef,
|
||||
pass => undef,
|
||||
auth_mode => 'PASS',
|
||||
debug => 0,
|
||||
blocking => 0,
|
||||
ssl => 0,
|
||||
timeout => 30, # The connection timeout (passed to GT::Socket::Client)
|
||||
data_timeout => 5, # The timeout to read/write data from/to the connected socket
|
||||
};
|
||||
|
||||
$ERRORS = {
|
||||
NOTCONNECTED => "You are calling %s and you have not connected yet!",
|
||||
CANTCONNECT => "Could not connect to POP3 server: %s",
|
||||
READ => "Unble to read from socket, reason (%s). Read: (%s)",
|
||||
WRITE => "Unable to write %s length to socket. Wrote %s, Error(%s)",
|
||||
NOEOF => "No EOF or EOL found. Socket locked.",
|
||||
ACTION => "Could not %s. Server said: %s",
|
||||
NOMD5 => "Unable to load GT::MD5 (required for APOP authentication): %s",
|
||||
PARSE => "An error occured while parsing an email: %s",
|
||||
LOGIN => "An error occured while logging in: %s",
|
||||
OPEN => "Could not open (%s) for read and write. Reason: %s",
|
||||
};
|
||||
|
||||
sub head_part {
|
||||
# --------------------------------------------------------
|
||||
# my $head = $obj->head_part($num);
|
||||
# ---------------------------------
|
||||
# This method takes one argument, the number message to
|
||||
# parse. It returns a GT::Mail::Parts object that has
|
||||
# only the top level head part parsed.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->head_part ($msg_num)');
|
||||
my $io = '';
|
||||
$self->top($num, sub { $io .= $_[0] }) or return;
|
||||
return GT::Mail::Parse->new(debug => $self->{_debug}, crlf => $CRLF)->parse_head(\$io);
|
||||
}
|
||||
|
||||
sub all_head_parts {
|
||||
# --------------------------------------------------------
|
||||
# my @heads = $obj->all_head_parts;
|
||||
# ---------------------------------
|
||||
# This does much the same as head_part() but returns an
|
||||
# array of GT::Mail::Parts objects, each one only having
|
||||
# the head of the message parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
my @head_parts;
|
||||
for (1 .. $self->stat) {
|
||||
my $part = $self->head_part($_) or return;
|
||||
push(@head_parts, $part);
|
||||
}
|
||||
return wantarray ? @head_parts : \@head_parts;
|
||||
}
|
||||
|
||||
sub parse_message {
|
||||
# --------------------------------------------------------
|
||||
# my $mail = $obj->parse_message($num);
|
||||
# -------------------------------------
|
||||
# This method returns a GT::Mail object. It calles parse
|
||||
# for the message number specified before returning the
|
||||
# object. You can retrieve the different parts of the
|
||||
# message through the GT::Mail object. If this method
|
||||
# fails you should check $GT::Mail::error.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->parse_message($msg_num)');
|
||||
my $io = $self->retr($num) or return;
|
||||
my $parser = new GT::Mail::Parse(debug => $self->{_debug}, in_string => $io, crlf => $CRLF);
|
||||
$parser->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------
|
||||
# Initilize the POP box object.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
$self->set(@_);
|
||||
|
||||
for (qw/user pass host/) {
|
||||
(defined($self->{$_})) or return $self->error('BADARGS', 'FATAL', "CLASS->new(%ARGS); The '$_' key in the hash must exists");
|
||||
}
|
||||
$self->{_debug} = exists($self->{debug}) ? delete($self->{debug}) : $DEBUG;
|
||||
|
||||
# Can be either PASS or APOP depending on login type.
|
||||
$self->{auth_mode} ||= 'PASS';
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub send {
|
||||
# --------------------------------------------------------
|
||||
# Send a message to the server.
|
||||
#
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
unless (defined $msg and length $msg) {
|
||||
$self->debug("Sending blank message!") if $self->{_debug};
|
||||
return;
|
||||
}
|
||||
|
||||
# Get the socket and end of line.
|
||||
my $s = $self->{sock};
|
||||
defined($s) and defined fileno($s) or return $self->error("NOTCONNECTED", "WARN", "send()");
|
||||
|
||||
# Print the message.
|
||||
$self->debug("--> $msg") if $self->{_debug};
|
||||
|
||||
$s->write($msg . $CRLF);
|
||||
|
||||
$self->getline(my $line) or return;
|
||||
|
||||
$line =~ s/$CRLF//o if $line;
|
||||
$line ||= 'Nothing sent back';
|
||||
$self->{message} = $line;
|
||||
$self->debug("<-- $line") if $self->{_debug};
|
||||
|
||||
return $line;
|
||||
}
|
||||
|
||||
sub getline {
|
||||
# --------------------------------------------------------
|
||||
# Read a line of input from the server.
|
||||
#
|
||||
my ($self) = @_;
|
||||
my $got_cr;
|
||||
my $safety;
|
||||
my $s = $self->{sock};
|
||||
$s->readline($_[1]);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub getall {
|
||||
# --------------------------------------------------------
|
||||
# Get all pending output from the server.
|
||||
#
|
||||
my ($self) = @_;
|
||||
$_[1] = '';
|
||||
my $l = 0;
|
||||
my $safety;
|
||||
my $s = $self->{sock};
|
||||
if ($self->{blocking}) {
|
||||
while (<$s>) {
|
||||
last if /^\.$CRLF/o;
|
||||
s/^\.//; # Lines starting with a . are doubled up in POP3
|
||||
$_[1] .= $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $save = $s->read_size;
|
||||
$s->read_size(1048576);
|
||||
$s->readalluntil("\n.$CRLF", $_[1], ".$CRLF");
|
||||
$s->read_size($save);
|
||||
|
||||
$_[1] =~ s/\n\.\r?\n$/\n/; # Remove the final . at the end of the e-mail
|
||||
$_[1] =~ s/^\.//mg; # Remove the initial '.' from any lines beginning with .
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub connect {
|
||||
# --------------------------------------------------------
|
||||
# Connect to the server.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($s, $iaddr, $msg, $paddr, $proto);
|
||||
|
||||
$self->debug("Attempting to connect .. ") if ($self->{_debug});
|
||||
|
||||
$self->{blocking} = 1 if $self->{ssl};
|
||||
$self->{port} ||= $self->{ssl} ? 995 : 110;
|
||||
|
||||
# If there was an existing connection, it'll be closed here when we reassign
|
||||
$self->{sock} = GT::Socket::Client->open(
|
||||
port => $self->{port},
|
||||
host => $self->{host},
|
||||
max_down => 0,
|
||||
timeout => $self->{timeout},
|
||||
non_blocking => !$self->{blocking},
|
||||
select_time => TIMEOUT,
|
||||
read_wait => $self->{data_timeout},
|
||||
ssl => $self->{ssl},
|
||||
debug => $self->{_debug}
|
||||
) or return $self->error("CANTCONNECT", "WARN", GT::Socket::Client->error);
|
||||
|
||||
$self->debug('Connected to ' . $self->{host} . ' on port ' . $self->{port} . ($self->{ssl} ? ' via SSL' : '')) if $self->{_debug};
|
||||
|
||||
# Get server welcoming.
|
||||
$self->getline($msg) or return;
|
||||
|
||||
# Store this - it's needed for APOP authentication
|
||||
$self->{msg_id}= $1 if ($msg =~ /(<[\w\d\-\.]+\@[\w\d\-\.]+>)/);
|
||||
|
||||
$self->debug("Going to login") if $self->{_debug};
|
||||
return $self->login();
|
||||
}
|
||||
|
||||
sub login {
|
||||
# --------------------------------------------------------
|
||||
# Login either using APOP or regular.
|
||||
#
|
||||
my $self = shift;
|
||||
($self->{auth_mode} eq 'APOP' && $self->{msg_id}) ? $self->login_apop : $self->login_pass;
|
||||
}
|
||||
|
||||
sub login_apop {
|
||||
# --------------------------------------------------------
|
||||
# Login using APOP.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($hash, $count, $line);
|
||||
{
|
||||
local $SIG{__DIE__};
|
||||
eval { require GT::MD5; 1 } or return $self->error('NOMD5', 'WARN', $@);
|
||||
}
|
||||
$self->debug("Attempting to log in via APOP ... ") if $self->{_debug};
|
||||
$hash = GT::MD5::md5_hex($self->{msg_id} . $self->{pass});
|
||||
|
||||
local ($_) = $self->send('APOP ' . $self->{user} . ' ' . $hash) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error("LOGIN", "WARN", "APOP Login failed: $_");
|
||||
if (/^\+OK \S+ has (\d+) /i) {
|
||||
$self->{count} = $1;
|
||||
}
|
||||
elsif (uc substr($_, 0, 3) ne '+OK') {
|
||||
return $self->error('LOGIN', 'WARN', $_);
|
||||
}
|
||||
$self->{state} = 'TRANSACTION';
|
||||
$self->stat() or return;
|
||||
|
||||
$self->debug("APOP Login successful.") if $self->{_debug};
|
||||
return (($self->{count} == 0) ? '0E0' : $self->{count});
|
||||
}
|
||||
|
||||
sub login_pass {
|
||||
# --------------------------------------------------------
|
||||
# Login using clear text authentication.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($line);
|
||||
|
||||
$self->debug("Attempting to log in via clear text ... ") if $self->{_debug};
|
||||
|
||||
# Enter username.
|
||||
local($_) = $self->send('USER ' . $self->{user}) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "USER POP Login failed: $_");
|
||||
|
||||
# Enter password.
|
||||
$_ = $self->send('PASS ' . $self->{pass}) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "PASS POP Login failed: $_");
|
||||
|
||||
# Ok, get total number of message, and pop box status.
|
||||
if (/^\+OK \S+ has (\d+) /i) {
|
||||
$self->{count} = $1;
|
||||
}
|
||||
elsif (uc substr($_, 0, 3) ne '+OK') {
|
||||
return $self->error('LOGIN', 'WARN', $_);
|
||||
}
|
||||
$self->stat() or return;
|
||||
|
||||
$self->debug("Login successful.") if $self->{_debug};
|
||||
return $self->{count} == 0 ? '0E0' : $self->{count};
|
||||
}
|
||||
|
||||
sub top {
|
||||
# --------------------------------------------------------
|
||||
# Get the header of a message and the next x lines (optional).
|
||||
#
|
||||
my ($self, $num, $code) = @_;
|
||||
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->head($msg_num);. No message number passed to head.');
|
||||
$self->debug("Getting head of message $num ... ") if $self->{_debug};
|
||||
|
||||
local($_) = $self->send("TOP $num 0") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "TOP $num 0", "($_)");
|
||||
|
||||
my ($tp, $header);
|
||||
$self->getall($header);
|
||||
if (substr($header, 0, 1) eq '>') {
|
||||
substr($header, 0, index($header, $CRLF) + 2) = '';
|
||||
}
|
||||
|
||||
# Support broken headers which given unix linefeeds.
|
||||
if ($header =~ /[^\r]\n/) {
|
||||
$header =~ s/\r?\n/$CRLF/g;
|
||||
}
|
||||
$self->debug("Top of message $num retrieved.") if $self->{_debug};
|
||||
if ($code and ref $code eq 'CODE') {
|
||||
$code->($header);
|
||||
}
|
||||
else {
|
||||
return wantarray ? split(/$CRLF/o, $header) : $header;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub retr {
|
||||
# --------------------------------------------------------
|
||||
# Get the entire message.
|
||||
#
|
||||
my ($self, $num, $code) = @_;
|
||||
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->retr ($msg_numm, $code);');
|
||||
|
||||
$self->debug("Getting message $num ... ") if ($self->{_debug});
|
||||
|
||||
# Get the size of the message
|
||||
local ($_) = $self->send("RETR $num") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', "RETR $num", $_);
|
||||
|
||||
# Retrieve the entire email
|
||||
my $body = '';
|
||||
$self->getall($body);
|
||||
|
||||
# Qmail puts this wierd header as the first line
|
||||
if (substr($body, 0, 1) eq '>') {
|
||||
substr($body, 0, index($body, $CRLF) + 2) = '';
|
||||
}
|
||||
|
||||
# Support broken pop servers that send us unix linefeeds.
|
||||
if ($body =~ /[^\r]\n/) {
|
||||
$body =~ s/\r?\n/$CRLF/g;
|
||||
}
|
||||
$self->debug("Message $num retrieved.") if $self->{_debug};
|
||||
if ($code and ref $code eq 'CODE') {
|
||||
$code->($body);
|
||||
}
|
||||
else {
|
||||
return \$body;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub last {
|
||||
my ($self) = @_;
|
||||
|
||||
local($_) = $self->send("LAST") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LAST", $_);
|
||||
s/^\+OK\s*//i;
|
||||
return $_;
|
||||
}
|
||||
|
||||
sub message_save {
|
||||
# --------------------------------------------------------
|
||||
# Get a message and save it to a file rather then returning.
|
||||
#
|
||||
my ($self, $num, $file) = @_;
|
||||
|
||||
# Check arguments.
|
||||
$num or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
|
||||
$file or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
|
||||
|
||||
my $io;
|
||||
if (ref $file) {
|
||||
$io = $file;
|
||||
}
|
||||
else {
|
||||
$file =~ /^\s*(.+?)\s*$/ and $file = $1;
|
||||
$io = \do { local *FH; *FH };
|
||||
open $io, ">$file" or return $self->error("OPENWRITE", "FATAL", $file, "$!");
|
||||
}
|
||||
|
||||
# Get the entire message body.
|
||||
$self->retr($num, sub { print $io $_[0] });
|
||||
$self->debug("Message $num saved to '$file'.") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub stat {
|
||||
# --------------------------------------------------------
|
||||
# Handle a stat command, get the number of messages and size.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
local($_) = $self->send("STAT") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', 'STAT', $_);
|
||||
if (/^\+OK (\d+) (\d+)/i) {
|
||||
$self->{count} = $1;
|
||||
$self->{size} = $2;
|
||||
$self->debug("STAT successful - count: $1 size: $2") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
$self->debug("STAT failed, can't determine count.") if $self->{_debug};
|
||||
}
|
||||
return $self->{count} || "0E0";
|
||||
}
|
||||
|
||||
sub list {
|
||||
# --------------------------------------------------------
|
||||
# Return a list of messages available.
|
||||
#
|
||||
my $self = shift;
|
||||
my $num = shift || '';
|
||||
my @messages;
|
||||
|
||||
# Broken pop servers that don't like 'LIST '.
|
||||
my $cmd = ($num eq '') ? 'LIST' : "LIST $num";
|
||||
|
||||
local($_) = $self->send($cmd) or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LIST $num", $_);
|
||||
if ($num) {
|
||||
s/^\+OK\s*//i;
|
||||
return $_;
|
||||
}
|
||||
my $msg = '';
|
||||
$self->getall($msg);
|
||||
@messages = split /$CRLF/o => $msg;
|
||||
$self->debug(@messages . " messages listed.") if ($self->{_debug});
|
||||
if (@messages) {
|
||||
return wantarray ? @messages : join("", @messages);
|
||||
}
|
||||
}
|
||||
|
||||
sub rset {
|
||||
# --------------------------------------------------------
|
||||
# Reset deletion stat.
|
||||
#
|
||||
my $self = shift;
|
||||
local($_) = $self->send("RSET") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "RSET", $_);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub dele {
|
||||
# --------------------------------------------------------
|
||||
# Delete a given message.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->dele ($msg_num)');
|
||||
local($_) = $self->send("DELE $num") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "DELE $num", $_);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub quit {
|
||||
# --------------------------------------------------------
|
||||
# Close the socket.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->send("QUIT") or return;
|
||||
close $self->{sock};
|
||||
$self->{sock} = undef;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uidl {
|
||||
# --------------------------------------------------------
|
||||
# Returns a list of uidls from the remote server
|
||||
#
|
||||
my $self = shift;
|
||||
my $num = shift;
|
||||
local $_;
|
||||
if ($num and !ref $num) {
|
||||
$_ = $self->send("UIDL $num") or return;
|
||||
/^\+OK \d+ (.+)$/i or return $self->error("ACTION", "WARN", "UIDL $num", $_);
|
||||
return $1;
|
||||
}
|
||||
my $ret = {};
|
||||
$_ = $self->send("UIDL") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "UIDL $num", $_);
|
||||
my $list = '';
|
||||
$self->getall($list);
|
||||
for (split /$CRLF/o => $list) {
|
||||
if ($num and ref($num) eq 'CODE') {
|
||||
$num->($_);
|
||||
}
|
||||
else {
|
||||
/^(\d+) (.+)/ and $ret->{$1} = $2;
|
||||
}
|
||||
}
|
||||
return wantarray ? %{$ret} : $ret;
|
||||
}
|
||||
|
||||
sub count {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for number of messages waiting.
|
||||
#
|
||||
return $_[0]->{count};
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for size of messages waiting.
|
||||
#
|
||||
return $_[0]->{count};
|
||||
}
|
||||
|
||||
sub last_message {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for last server message.
|
||||
|
||||
@_ == 2 and $_[0]->{message} = $_[1];
|
||||
return $_[0]->{message};
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# --------------------------------------------------------
|
||||
# Auto close the socket.
|
||||
#
|
||||
my $self = shift;
|
||||
if ($self->{sock} and defined fileno($self->{sock})) {
|
||||
$self->send("QUIT");
|
||||
close $self->{sock};
|
||||
$self->{sock} = undef;
|
||||
}
|
||||
$self->debug("POP Object destroyed.") if ($self->{_debug} > 1);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::POP3 - Receieve email through POP3 protocal
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::POP3;
|
||||
|
||||
my $pop = GT::Mail::POP3->new(
|
||||
host => 'mail.gossamer-threads.com',
|
||||
port => 110,
|
||||
user => 'someusername',
|
||||
pass => 'somepassword',
|
||||
auth_mode => 'PASS',
|
||||
timeout => 30,
|
||||
debug => 1
|
||||
);
|
||||
|
||||
my $count = $pop->connect or die $GT::Mail::POP3::error;
|
||||
|
||||
for my $num (1 .. $count) {
|
||||
my $top = $pop->parse_head($num);
|
||||
|
||||
my @to = $top->split_field;
|
||||
|
||||
if (grep /myfriend\@gossamer-threads\.com/, @to) {
|
||||
$pop->message_save($num, '/keep/email.txt');
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::POP3 is a module to check an email account using the POP3 protocol.
|
||||
Many of the methods are integrated with L<GT::Mail::Parse>.
|
||||
|
||||
=head2 new - constructor method
|
||||
|
||||
This method is inherited from L<GT::Base>. The argument to this method can be
|
||||
in the form of a hash or hash ref. As a minimum 'user', 'pass', and 'host' must
|
||||
be specified.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debugging level for this instance of GT::Mail::POP3.
|
||||
|
||||
=item host
|
||||
|
||||
Sets the host to connect to for checking a POP account. This argument must be
|
||||
provided.
|
||||
|
||||
=item port
|
||||
|
||||
Sets the port on the POP server to attempt to connect to. This defaults to 110,
|
||||
unless using SSL, for which the default is 995.
|
||||
|
||||
=item ssl
|
||||
|
||||
Establishes the connection using SSL. Note that this requires Net::SSLeay of
|
||||
at least version 1.06.
|
||||
|
||||
=item user
|
||||
|
||||
Sets the user name to login with when connecting to the POP server. This must
|
||||
be specified.
|
||||
|
||||
=item pass
|
||||
|
||||
Sets the password to login with when connection to the POP server. This must be
|
||||
specified.
|
||||
|
||||
=item auth_mode
|
||||
|
||||
Sets the authentication type for this connection. This can be one of two
|
||||
values. PASS (the default) or APOP. If set to APOP, GT::Mail::POP3 will use
|
||||
APOP to login to the remote server.
|
||||
|
||||
=item timeout
|
||||
|
||||
Sets the connection timeout. This isn't entirely reliable as it uses alarm(),
|
||||
which isn't supported on all systems. That aside, this normally isn't needed
|
||||
if you want a timeout - it defaults to 30 on alarm()-supporting systems. The
|
||||
main purpose is to provide a value of 0 to disable the alarm() timeout.
|
||||
|
||||
=back
|
||||
|
||||
=head2 connect - Connect to the POP account
|
||||
|
||||
$obj->connect or die $GT::Mail::POP3::error;
|
||||
|
||||
This method performs the connection to the POP server. Returns the count of
|
||||
messages on the server on success, and undefined on failure. Takes no arguments
|
||||
and called before you can perform any actions on the POP server.
|
||||
|
||||
=head2 head_part - Access the email header
|
||||
|
||||
# Get a parsed header part object for the first email in the list.
|
||||
my $top_part = $obj->head_part(1);
|
||||
|
||||
Instance method. The only argument to this method is the message number to get.
|
||||
Returns a L<GT::Mail::Parts> object containing only the parsed header of the
|
||||
specified message.
|
||||
|
||||
=head2 all_head_parts - Access all email headers
|
||||
|
||||
# Get all the head parts from all messages
|
||||
my @headers = $obj->all_head_parts;
|
||||
|
||||
Instance method. Gets all the headers of all the email's on the remote server.
|
||||
Returns an array of the L<GT::Mail::Parts> object. One object for each
|
||||
email. None of the email's bodies are retrieved, only the head.
|
||||
|
||||
=head2 parse_message - Access an email
|
||||
|
||||
# Parse an email and get the GT::Mail object
|
||||
my $mail = $obj->parse_message (1);
|
||||
|
||||
Instance method. Pass in the number of the email to retrieve. This method
|
||||
retrieves the specified email and returns the parsed GT::Mail object. If this
|
||||
method fails you should check $GT::Mail::error for the error message.
|
||||
|
||||
=head2 message_save - Save an email
|
||||
|
||||
open FH, '/path/to/email.txt' or die $!;
|
||||
|
||||
# Save message 2 to file
|
||||
$obj->message_save (2, \*FH);
|
||||
close FH;
|
||||
|
||||
- or -
|
||||
|
||||
$obj->message_save (2, '/path/to/email.txt') or die $GT::Mail::POP3::error;
|
||||
|
||||
Instance method. This method takes the message number as it's first argument,
|
||||
and either a file path or a file handle ref as it's second argument. If a file
|
||||
path is provided the file will be opened to truncate. The email is then
|
||||
retrieved from the server and written to the file.
|
||||
|
||||
=head2 stat - Do a STAT command
|
||||
|
||||
# Get the number of messages on the server
|
||||
my $count = $obj->stat;
|
||||
|
||||
Instance method. Does a STAT command on the remote server. It stores the total
|
||||
size and returns the count of messages on the server, if successful. Otherwise
|
||||
returns undef.
|
||||
|
||||
=head2 list - Do a LIST command
|
||||
|
||||
# At a list of messages on the server
|
||||
my @messages = $obj->list;
|
||||
|
||||
Instance method. Does a LIST command on the remote server. Returns an array of
|
||||
the lines in list context and a single scalar that contains all the lines in
|
||||
scalar context.
|
||||
|
||||
=head2 rset - Do an RSET command
|
||||
|
||||
# Tell the server to ignore any dele commands we have issued in this
|
||||
# session
|
||||
$obj->rset;
|
||||
|
||||
Instance method. Does an RSET command. This command resets the servers
|
||||
knowledge of what should be deleted when QUIT is called. Returns 1 on success.
|
||||
|
||||
=head2 dele - Do a DELE command
|
||||
|
||||
# Delete message 4
|
||||
$obj->dele (4);
|
||||
|
||||
Instance method. Does a DELE command. The only argument is the message number
|
||||
to delete. Returns 1 on success.
|
||||
|
||||
=head2 quit - Quit the connection
|
||||
|
||||
# Close our connection
|
||||
$obj->quit;
|
||||
|
||||
Instance method. Sends the QUIT command to the server. The should should
|
||||
disconnect soon after this. No more actions can be taken on this connection
|
||||
until connect is called again.
|
||||
|
||||
=head2 uidl - Do a UIDL command
|
||||
|
||||
# Get the uidl for message 1
|
||||
my $uidl = $obj->uidl (1);
|
||||
|
||||
# Get a list of all the uidl's and print them
|
||||
$obj->uidl (sub { print @_ });
|
||||
|
||||
# Get an array of all the uidl's
|
||||
my @uidl = $obj->uidl;
|
||||
|
||||
Instance method. Attempts to do a UIDL command on the remote server. Please be
|
||||
aware support for the UIDL command is not very wide spread. This method can
|
||||
take the message number as it's first argument. If the message number is given,
|
||||
the UIDL for that message is returned. If the first argument is a code
|
||||
reference, a UIDL command is done with no message specified and the code
|
||||
reference is called for each line returned from the remote server. If no second
|
||||
argument is given, a UIDL command is done, and the results are returned in a
|
||||
has of message number to UIDL.
|
||||
|
||||
=head2 count - Get the number of messages
|
||||
|
||||
# Get the count from the last STAT
|
||||
my $count = $obj->count;
|
||||
|
||||
This method returns the number of messages on the server from the last STAT
|
||||
command. A STAT is done on connect.
|
||||
|
||||
=head2 size - Get the size of all messages
|
||||
|
||||
# Get the total size of all messages on the server
|
||||
my $size = $obj->size;
|
||||
|
||||
This method returns the size of all messages in the server as returned by the
|
||||
last STAT command sent to the server.
|
||||
|
||||
=head2 send - Send a raw command
|
||||
|
||||
# Send a raw command to the server
|
||||
my $ret = $obj->send ("HELO");
|
||||
|
||||
This method sends the specified raw command to the POP server. The one line
|
||||
return from the server is returned. Do not call this method if you are
|
||||
expecting more than a one line response.
|
||||
|
||||
=head2 top - Retrieve the header
|
||||
|
||||
# Get the header of message 2 in an array. New lines are stripped
|
||||
my @header = $obj->top (2);
|
||||
|
||||
# Get the header as a string
|
||||
my $header = $obj->top (2);
|
||||
|
||||
Instance method to retrieve the top of an email on the POP server. The only
|
||||
argument should be the message number to retrieve. Returns a scalar containing
|
||||
the header in scalar context and an array, which is the scalar split on
|
||||
\015?\012, in list context.
|
||||
|
||||
=head2 retr - Retrieve an email
|
||||
|
||||
# Get message 3 from the remote server in an array. New lines are stripped
|
||||
my @email = $obj->retr (3);
|
||||
|
||||
# Get it as a string
|
||||
my $email = $obj->retr (3);
|
||||
|
||||
Instance method to retrieve an email from the POP server. The first argument to
|
||||
this method should be the message number to retrieve. The second argument is an
|
||||
optional code ref to call for each line of the message that is retrieved. If no
|
||||
code ref is specified, this method will put the email in a scalar and return
|
||||
the scalar in scalar context and return the scalar split on \015?\012 in list
|
||||
context.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
L<GT::Socket::Client>
|
||||
L<GT::Base>
|
||||
L<GT::MD5> (for APOP authentication)
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: POP3.pm,v 1.56 2004/03/19 00:36:16 brewt Exp $
|
||||
|
||||
788
site/glist/lib/GT/Mail/Parse.pm
Normal file
788
site/glist/lib/GT/Mail/Parse.pm
Normal file
@ -0,0 +1,788 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Parse
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Parse.pm,v 1.79 2004/10/23 02:16:39 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::Mail::Parse;
|
||||
# =============================================================================
|
||||
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04 wipes
|
||||
# our ISA.
|
||||
my $have_b64 = eval {
|
||||
local $SIG{__DIE__};
|
||||
require MIME::Base64;
|
||||
import MIME::Base64;
|
||||
if ($] < 5.005) { local $^W; decode_base64('brok'); }
|
||||
1;
|
||||
};
|
||||
$have_b64 or *decode_base64 = \>_old_decode_base64;
|
||||
my $use_decode_qp;
|
||||
if ($have_b64 and
|
||||
$MIME::Base64::VERSION >= 2.16 and # Prior versions had decoding bugs
|
||||
defined &MIME::QuotedPrint::decode_qp and (
|
||||
not defined &MIME::QuotedPrint::old_decode_qp or
|
||||
\&MIME::QuotedPrint::decode_qp != \&MIME::QuotedPrint::old_decode_qp
|
||||
)
|
||||
) {
|
||||
$use_decode_qp = 1;
|
||||
}
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG $ERRORS $CRLF $CR_LN @ISA);
|
||||
|
||||
# System modules
|
||||
use Fcntl;
|
||||
|
||||
# Internal modules
|
||||
use GT::Mail::Parts;
|
||||
use GT::Base;
|
||||
|
||||
# Inherent from GT::Base for errors and debug
|
||||
@ISA = qw(GT::Base);
|
||||
|
||||
# Debugging mode
|
||||
$DEBUG = 0;
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = substr q$Revision: 1.79 $, 10;
|
||||
|
||||
# The CRLF sequence:
|
||||
$CRLF = "\n";
|
||||
|
||||
# The length of a crlf
|
||||
$CR_LN = 1;
|
||||
|
||||
# Error messages
|
||||
$ERRORS = {
|
||||
PARSE => "An error occured while parsing: %s",
|
||||
DECODE => "An error occured while decoding: %s",
|
||||
NOPARTS => "Email has no parts!",
|
||||
DEEPPARTS => "Deep recursion dected, email appears to have more than 50 parts!",
|
||||
MALFORMED => "Found (%s) before finding the start of the boundary. Message malformed"
|
||||
};
|
||||
|
||||
my %DecoderFor = (
|
||||
# Standard...
|
||||
'7bit' => 'NBit',
|
||||
'8bit' => 'NBit',
|
||||
'base64' => 'Base64',
|
||||
'binary' => 'Binary',
|
||||
'none' => 'Binary',
|
||||
'quoted-printable' => 'QuotedPrint',
|
||||
|
||||
# Non-standard...
|
||||
'x-uu' => 'UU',
|
||||
'x-uuencode' => 'UU',
|
||||
);
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------------------------
|
||||
# CLASS->new (
|
||||
# naming => \&naming,
|
||||
# in_file => '/path/to/file/to/parse',
|
||||
# handle => \*FH
|
||||
# );
|
||||
# ----------------------------------------------
|
||||
# Class method to get a new object. Calles init if there are any additional
|
||||
# argument. To set the arguments that are passed to naming call naming
|
||||
# directly.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {
|
||||
file_handle => undef,
|
||||
parts => [],
|
||||
head_part => undef,
|
||||
headers_intact => 1,
|
||||
_debug => $DEBUG,
|
||||
}, $class;
|
||||
$self->init(@_) if @_;
|
||||
$self->debug("Created new object ($self).") if $self->{_debug} > 1;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->init (%opts);
|
||||
# -------------------
|
||||
# Sets the options for the current object.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
else { return $self->error("BADARGS", "FATAL", "init") }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
|
||||
$self->{headers_intact} = exists($opt->{headers_intact}) ? $opt->{headers_intact} : 1;
|
||||
for my $m (qw(crlf in_file in_handle in_string attach_rfc822)) {
|
||||
$self->$m($opt->{$m}) if defined $opt->{$m};
|
||||
}
|
||||
}
|
||||
|
||||
sub attach_rfc822 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{attach_rfc822} = shift;
|
||||
}
|
||||
return $self->{attach_rfc822};
|
||||
}
|
||||
|
||||
sub crlf {
|
||||
# --------------------------------------------------------------------------
|
||||
$CRLF = pop || return $CRLF;
|
||||
$CR_LN = length($CRLF);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $top = $obj->parse;
|
||||
# ----------------------
|
||||
# Parses the email set in new or init. Also calls init if there are any
|
||||
# arguments passed in.
|
||||
# Returns the top level part object.
|
||||
#
|
||||
my ($self, @opts) = @_;
|
||||
|
||||
# Any additional arguments goto init
|
||||
$self->init(@opts) if @opts;
|
||||
|
||||
($self->{string} and ref($self->{string}) eq 'SCALAR')
|
||||
or return $self->error('BADARGS', 'FATAL', "No input was given to parse before parse() was called");
|
||||
|
||||
# Recursive function to parse
|
||||
$self->_parse_part(undef, $self->{string}); # parse!
|
||||
|
||||
# Return top part
|
||||
return $self->{head_part};
|
||||
}
|
||||
|
||||
sub parse_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $head = $obj->parse_head;
|
||||
# ----------------------------
|
||||
# Passes any additional arguments to init. Parses only the top level header.
|
||||
# This saves some overhead if for example all you need to do it find out who
|
||||
# an email is to on a POP3 server.
|
||||
#
|
||||
my ($self, $in, @opts) = @_;
|
||||
|
||||
unless (ref $self) {
|
||||
$self = $self->new(@opts);
|
||||
}
|
||||
|
||||
$in ||= $self->{string};
|
||||
$in || return $self->error("BADARGS", "FATAL", "No string to parse set!");
|
||||
|
||||
# Parse the head
|
||||
return $self->_parse_head($in);
|
||||
}
|
||||
|
||||
#--------------------------------------------
|
||||
# Access
|
||||
#--------------------------------------------
|
||||
|
||||
|
||||
sub in_handle {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->in_handle (\*FH);
|
||||
# --------------------
|
||||
# Pass in a file handle to parse from when parse is called.
|
||||
#
|
||||
my ($self, $value) = @_;
|
||||
if (@_ > 1 and ref $value and defined fileno $value) {
|
||||
read $value, ${$self->{string}}, -s $value;
|
||||
}
|
||||
return $self->{string};
|
||||
}
|
||||
|
||||
sub in_file {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->in_file ('/path/to/file');
|
||||
# --------------------------------
|
||||
# Pass in the path to a file to parse when parse is called
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = shift;
|
||||
my $io = \do { local *FH; *FH };
|
||||
open $io, "<$file" or return $self->error("READOPEN", "FATAL", $file, $!);
|
||||
return $self->in_handle($io);
|
||||
}
|
||||
|
||||
sub in_string {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $string) = @_;
|
||||
return $self->{string} unless (@_ > 1);
|
||||
if (ref($string) eq 'SCALAR') {
|
||||
$self->{string} = $string;
|
||||
}
|
||||
else {
|
||||
$self->{string} = \$string;
|
||||
}
|
||||
return $self->{string};
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $email_size = $obj->size;
|
||||
# ----------------------------
|
||||
# Returns the total size of an email. Call this method after the email has
|
||||
# been parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
(@{$self->{parts}} > 0) or return $self->error("NOPARTS", "WARN");
|
||||
my $size = 0;
|
||||
foreach (@{$self->{parts}}) {
|
||||
$size += $_->size;
|
||||
}
|
||||
return $size;
|
||||
}
|
||||
|
||||
sub all_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# my @parts = $obj->all_parts;
|
||||
# ----------------------------
|
||||
# Returns a list of all the part object for the current parsed email. If the
|
||||
# email is not multipart this will be just the header part.
|
||||
#
|
||||
return @{shift()->{parts}}
|
||||
}
|
||||
|
||||
sub top_part {
|
||||
# --------------------------------------------------------------------------
|
||||
return ${shift()->{parts}}[0];
|
||||
}
|
||||
|
||||
#---------------------------------------------
|
||||
# Internal Methods
|
||||
#---------------------------------------------
|
||||
|
||||
sub _parse_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parse just the head. Returns the part object.
|
||||
#
|
||||
my ($self, $in) = @_;
|
||||
|
||||
# Get a new part object
|
||||
my $part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
|
||||
if (ref $in eq 'ARRAY') {
|
||||
$part->extract($in) or return $self->error("PARSE", "WARN", "Couldn't parse head!");
|
||||
return $part;
|
||||
}
|
||||
$part->extract([map { $_ . $CRLF } split($CRLF => $$in)]) or return $self->error($GT::Mail::Parts::error, 'WARN');
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub _parse_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses all the parts of an email and stores them in there parts object.
|
||||
# This function is recursive.
|
||||
#
|
||||
my ($self, $outer_bound, $in, $part) = @_;
|
||||
my $state = 'OK';
|
||||
|
||||
# First part is going to be the top level part
|
||||
if (!$part) {
|
||||
$part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
$self->{head_part} = $part;
|
||||
}
|
||||
push @{$self->{parts}}, $part;
|
||||
|
||||
# Get the header for this part
|
||||
my $indx;
|
||||
if (($indx = index($$in, $CRLF)) == 0) {
|
||||
substr($$in, 0, $CR_LN) = '';
|
||||
}
|
||||
else {
|
||||
$indx = index($$in, ($CRLF . $CRLF));
|
||||
if ($indx == -1) {
|
||||
$self->debug('Message has no body.') if $self->{_debug};
|
||||
$indx = length($$in);
|
||||
}
|
||||
$part->extract([map { $_ . $CRLF } split($CRLF => substr($$in, 0, $indx))])
|
||||
or return $self->error($GT::Mail::Parts::error, 'WARN');
|
||||
substr($$in, 0, $indx + ($CR_LN * 2)) = '';
|
||||
}
|
||||
|
||||
# Get the mime type
|
||||
my ($type, $subtype) = split('/', $part->mime_type);
|
||||
$type ||= 'text';
|
||||
$subtype ||= 'plain';
|
||||
if ($self->{_debug}) {
|
||||
my $name = $part->recommended_filename || '[unnamed]';
|
||||
$self->debug("Type is '$type/$subtype' ($name)");
|
||||
}
|
||||
|
||||
# Deal with the multipart type with some recursion
|
||||
if ($type eq 'multipart') {
|
||||
my $retype = (($subtype eq 'digest') ? 'message/rfc822' : '');
|
||||
|
||||
# Find the multipart boundary
|
||||
my $inner_bound = $part->multipart_boundary;
|
||||
$self->debug("Boundary is $inner_bound") if $self->{_debug} > 1;
|
||||
defined $inner_bound or return $self->error("PARSE", "WARN", "No multipart boundary in multipart message.");
|
||||
index($inner_bound, $CRLF) == -1 or return $self->error("PARSE", "WARN", "CR or LF in multipart boundary.");
|
||||
|
||||
# Parse the Preamble
|
||||
$self->debug("Parsing preamble.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_preamble($inner_bound, $in, $part) or return;
|
||||
chomp($part->preamble->[-1]) if @{$part->preamble};
|
||||
|
||||
# Get all the parts of the multipart message
|
||||
my $partno = 0;
|
||||
my $parts;
|
||||
while (1) {
|
||||
++$partno < 200 or return $self->error('DEEPPARTS', 'WARN');
|
||||
$self->debug("Parsing part $partno.") if $self->{_debug};
|
||||
|
||||
($parts, $state) = $self->_parse_part($inner_bound, $in, GT::Mail::Parts->new(headers_intact => $self->{headers_intact})) or return;
|
||||
($state eq 'EOF') and return $self->error('PARSE', 'WARN', 'Unexpected EOF before close.');
|
||||
|
||||
$parts->mime_type($retype) if $retype;
|
||||
push(@{$part->{parts}}, $parts);
|
||||
|
||||
last if $state eq 'CLOSE';
|
||||
}
|
||||
|
||||
# Parse the epilogue
|
||||
$self->debug("Parsing epilogue.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_epilogue($outer_bound, $in, $part) or return;
|
||||
chomp($part->epilogue->[-1]) if @{$part->epilogue} and $state ne 'EOF';
|
||||
}
|
||||
|
||||
# We are on a single part
|
||||
else {
|
||||
$self->debug("Decoding single part.") if $self->{_debug} > 1;
|
||||
|
||||
# Find the encoding for the body of the part
|
||||
my $encoding = $part->mime_encoding || 'binary';
|
||||
if (!exists($DecoderFor{lc($encoding)})) {
|
||||
$self->debug("Unsupported encoding '$encoding': using 'binary'... \n" .
|
||||
"The entity will have an effective MIME type of \n" .
|
||||
"application/octet-stream, as per RFC-2045.")
|
||||
if $self->{_debug};
|
||||
$part->effective_type('application/octet-stream');
|
||||
$encoding = 'binary';
|
||||
}
|
||||
my $reparse;
|
||||
$reparse = ("$type/$subtype" eq "message/rfc822") unless $self->{attach_rfc822};
|
||||
my $encoded = "";
|
||||
|
||||
# If we have boundaries we parse the body to the boundary
|
||||
if (defined $outer_bound) {
|
||||
$self->debug("Parsing to boundary.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_to_bound($outer_bound, $in, \$encoded) or return;
|
||||
}
|
||||
# Else we would parse the rest of the input stream as the rest of the message
|
||||
else {
|
||||
$self->debug("No Boundries.") if $self->{_debug} > 1;
|
||||
$encoded = $$in;
|
||||
$state = 'EOF';
|
||||
}
|
||||
|
||||
# Normal part so we get the body and decode it.
|
||||
if (!$reparse) {
|
||||
$self->debug("Not reparsing.") if $self->{_debug} > 1;
|
||||
$part->{body_in} = 'MEMORY';
|
||||
|
||||
my $decoder = $DecoderFor{lc($encoding)};
|
||||
$self->debug("Decoding part using: " . lc($encoding)) if $self->{_debug};
|
||||
$part->{data} = '';
|
||||
my $out = '';
|
||||
my $res = $self->$decoder(\$encoded, \$out);
|
||||
undef $encoded;
|
||||
$res or return;
|
||||
$part->{data} = $out;
|
||||
undef $out;
|
||||
}
|
||||
else {
|
||||
# If have an embeded email we reparse it.
|
||||
$self->debug("Reparsing enclosed message.") if $self->{_debug};
|
||||
my $out = '';
|
||||
|
||||
my $decoder = $DecoderFor{lc($encoding)};
|
||||
$self->debug("Decoding " . lc($encoding)) if $self->{_debug};
|
||||
my $res = $self->$decoder(\$encoded, \$out);
|
||||
undef $encoded;
|
||||
$res or return;
|
||||
my $p = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
push @{$part->{parts}}, $p;
|
||||
$self->_parse_part(undef, \$out, $p) or return;
|
||||
}
|
||||
}
|
||||
return ($part, $state);
|
||||
}
|
||||
|
||||
sub _parse_to_bound {
|
||||
# --------------------------------------------------------------------------
|
||||
# This method takes a boundary ($bound), an input string ref ($in), and an
|
||||
# output string ref ($out). It will place into $$out the data contained by
|
||||
# $bound, and remove the entire region (including boundary) from $$in.
|
||||
#
|
||||
my ($self, $bound, $in, $out) = @_;
|
||||
|
||||
# Set up strings for faster checking:
|
||||
my ($delim, $close) = ("--$bound", "--$bound--");
|
||||
$self->debug("Parsing bounds. Skip until\n\tdelim ($delim)\n\tclose ($close)") if $self->{_debug} > 1;
|
||||
my ($pos, $ret);
|
||||
|
||||
# Place our part in $$out.
|
||||
$$out = undef;
|
||||
if (defined($pos = index($$in, "$CRLF$delim$CRLF")) and $pos != -1) {
|
||||
$$out = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length("$CRLF$delim$CRLF")) = "";
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
elsif (index($$in, "$delim$CRLF") == 0) {
|
||||
substr($$in, 0, length("$delim$CRLF")) = "";
|
||||
$$out = "";
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
elsif (defined($pos = index($$in, "$CRLF$close$CRLF")) and $pos != -1) {
|
||||
$$out = $$in;
|
||||
substr($$out, -(length($$out) - $pos)) = '';
|
||||
my $len = (length($$in) - (length("$CRLF$close$CRLF") + $pos)) * -1;
|
||||
if ($len == 0) {
|
||||
$$in = '';
|
||||
}
|
||||
else {
|
||||
$$in = substr($$in, $len);
|
||||
}
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, "$CRLF$close") == (length($$in) - length("$CRLF$close"))) {
|
||||
$$out = substr($$in, 0, length($$in) - length("$CRLF$close"));
|
||||
$$in = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, "$close$CRLF") == 0) {
|
||||
$$out = "";
|
||||
substr($$in, 0, length("$close$CRLF")) = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, $close) == 0 and (length($$in) == length($close))) {
|
||||
$$out = "";
|
||||
$$in = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
|
||||
if (defined $$out) {
|
||||
return $ret;
|
||||
}
|
||||
else {
|
||||
# Broken Email, retype to text/plain
|
||||
$self->{parts}->[$#{$self->{parts}}]->set('content-type' => 'text/plain');
|
||||
$$out = $$in;
|
||||
return 'CLOSE';
|
||||
}
|
||||
}
|
||||
|
||||
sub _parse_preamble {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses preamble and sets it in part.
|
||||
#
|
||||
my ($self, $inner_bound, $in, $part) = @_;
|
||||
|
||||
my $loc;
|
||||
my ($delim, $close) = ("--$inner_bound", "--$inner_bound--");
|
||||
|
||||
$self->debug("Parsing preamble. Skip until\n\tdelim ($delim)\n\tclose ($close)") if $self->{_debug} > 1;
|
||||
my @saved;
|
||||
$part->preamble(\@saved);
|
||||
|
||||
my ($data, $pos, $len);
|
||||
if (index($$in, "$delim$CRLF") == 0) {
|
||||
$data = '';
|
||||
substr($$in, 0, length("$delim$CRLF")) = '';
|
||||
}
|
||||
else {
|
||||
$pos = index($$in, "$CRLF$delim$CRLF");
|
||||
if ($pos >= 0) {
|
||||
$data = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length("$CRLF$delim$CRLF")) = '';
|
||||
}
|
||||
elsif ($pos == -1) {
|
||||
return $self->error('PARSE', 'WARN', "Unable to find opening boundary: " .
|
||||
"$delim\n" .
|
||||
"Message is probably corrupt.");
|
||||
}
|
||||
}
|
||||
push @saved, split $CRLF => $data;
|
||||
undef $data;
|
||||
return 'DELIM';
|
||||
}
|
||||
|
||||
sub _parse_epilogue {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses epilogue and sets it in part.
|
||||
#
|
||||
my ($self, $outer_bound, $in, $part) = @_;
|
||||
my ($delim, $close, $loc);
|
||||
|
||||
($delim, $close) = ("--$outer_bound", "--$outer_bound--") if defined $outer_bound;
|
||||
|
||||
$self->debug("Parsing epilogue. Skip until\n\tdelim (" . ($delim || '') .
|
||||
")\n\tclose (" . ($close || '') . ")")
|
||||
if $self->{_debug} > 1;
|
||||
my @saved;
|
||||
$part->epilogue(\@saved);
|
||||
if (defined $outer_bound) {
|
||||
if ($$in =~ s/(.*?)(?:\A|$CRLF)\Q$delim\E$CRLF//s) {
|
||||
push(@saved, split($CRLF => $1));
|
||||
$self->debug("Found delim($delim)") if $self->{_debug};
|
||||
return 'DELIM'
|
||||
}
|
||||
elsif ($$in =~ s/(.*?)(?:\A|$CRLF)\Q$close\E(?:\Z|$CRLF)//s) {
|
||||
push(@saved, split($CRLF => $1));
|
||||
$self->debug("Found close($close)") if $self->{_debug};
|
||||
return 'CLOSE'
|
||||
}
|
||||
}
|
||||
push(@saved, split($CRLF => $$in));
|
||||
$$in = '';
|
||||
$self->debug("EOF: epilogue is " . length(join '', @saved) . " bytes") if $self->{_debug};
|
||||
return 'EOF';
|
||||
}
|
||||
|
||||
|
||||
sub Base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
# Remove any non base64 characters.
|
||||
$$in =~ tr{A-Za-z0-9+/}{}cd;
|
||||
|
||||
# Must pass multiple of 4 to decode_base64. Store any remainder in $rem_str and
|
||||
# pad it with trailing equal signs.
|
||||
my $rem = length($$in) % 4;
|
||||
my ($rem_str);
|
||||
if ($rem) {
|
||||
my $pad = '=' x (4 - $rem);
|
||||
$rem_str = substr($$in, length($$in) - $rem);
|
||||
$rem_str .= $pad;
|
||||
substr($$in, $rem * -1) = '';
|
||||
}
|
||||
|
||||
$$out = decode_base64($$in);
|
||||
if ($rem) {
|
||||
$$out .= decode_base64($rem_str);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub Binary {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
$$out = $$in;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub NBit {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
$$out = $$in;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub QuotedPrint {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
if ($use_decode_qp) {
|
||||
$$out = MIME::QuotedPrint::decode_qp($$in);
|
||||
}
|
||||
else {
|
||||
$$out = $$in;
|
||||
$$out =~ s/\r\n/\n/g; # normalize newlines
|
||||
$$out =~ s/[ \t]+\n/\n/g; # rule #3 (trailing whitespace must be deleted)
|
||||
$$out =~ s/=\n//g; # rule #5 (soft line breaks)
|
||||
$$out =~ s/=([\da-fA-F]{2})/chr hex $1/ge;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub UU {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
my ($mode, $file);
|
||||
|
||||
# Find beginning...
|
||||
while ($$in =~ s/^(.+$CRLF)//o) {
|
||||
local $_ = $1;
|
||||
last if ($mode, $file) = /^begin\s*(\d*)\s*(\S*)/;
|
||||
}
|
||||
return $self->error("uu decoding: no begin found", 'WARN') if (!defined($_));
|
||||
|
||||
# Decode:
|
||||
while ($$in =~ s/^(.+$CRLF)//o) {
|
||||
local $_ = $1;
|
||||
last if /^end/;
|
||||
next if /[a-z]/;
|
||||
next unless int((((ord() - 32) & 077) + 2) / 3) == int(length($_) / 4);
|
||||
$$out .= unpack('u', $_);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub gt_old_decode_base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $str = shift;
|
||||
my $res = "";
|
||||
|
||||
$str =~ tr|A-Za-z0-9+=/||cd;
|
||||
|
||||
$str =~ s/=+$//;
|
||||
$str =~ tr|A-Za-z0-9+/| -_|;
|
||||
return "" unless length $str;
|
||||
|
||||
my $uustr = '';
|
||||
my ($i, $l);
|
||||
$l = length($str) - 60;
|
||||
for ($i = 0; $i <= $l; $i += 60) {
|
||||
$uustr .= "M" . substr($str, $i, 60);
|
||||
}
|
||||
$str = substr($str, $i);
|
||||
# and any leftover chars
|
||||
if ($str ne "") {
|
||||
$uustr .= chr(32 + length($str)*3/4) . $str;
|
||||
}
|
||||
return unpack("u", $uustr);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Parse - MIME Parse
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Parse
|
||||
|
||||
my $parser = new GT::Mail::Parse (
|
||||
naming => \&name_files,
|
||||
in_file => '/path/to/file.eml',
|
||||
debug => 1
|
||||
);
|
||||
|
||||
my $top = $parser->parse or die $GT::Mail::Parse::error;
|
||||
|
||||
- or -
|
||||
|
||||
my $parser = new GT::Mail::Parse;
|
||||
|
||||
open FH, '/path/to/file.eml' or die $!;
|
||||
my $top = $parser->parse (
|
||||
naming => \&name_files,
|
||||
handle => \*FH,
|
||||
debug => 1
|
||||
) or die $GT::Mail::Parse::error;
|
||||
close FH;
|
||||
|
||||
- or -
|
||||
|
||||
my $parser = new GT::Mail::Parse;
|
||||
|
||||
my $top_head = $parser->parse_head (
|
||||
naming => \&name_files,
|
||||
in_file => '/path/to/file.eml',
|
||||
debug => 1
|
||||
) or die $GT::Mail::Parse::error;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Parse is a 100% rfc822 email MIME parser that supports unlimited
|
||||
nested levels of MIME. Emails are parsed into L<GT::Mail::Parts> objects. Each
|
||||
part knows where it's body is and each part contains it's sub parts. See
|
||||
L<GT::Mail::Parts> for details on parts methods.
|
||||
|
||||
=head2 new - Constructor method
|
||||
|
||||
This is the constructor method to get a GT::Mail::Parse object, which you
|
||||
need to access all the methods (there are no Class methods). new() takes
|
||||
a hash or hash ref as it's arguments. Each key has an accessor method by the
|
||||
same name except debug, which can only be set by passing debug to new(), parse()
|
||||
or parse_head().
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this insance of the class.
|
||||
|
||||
=item naming
|
||||
|
||||
Specify a code reference to use as a naming convention for each part of the
|
||||
email being parsed. This is useful to keep file IO down when you want the emails
|
||||
seperated into each part as a file. If this is not specified GT::Mail::Parse
|
||||
uses a default naming, which is to start at one and incriment that number for each
|
||||
attachment. The attachments would go in the current working directory.
|
||||
|
||||
=item in_file
|
||||
|
||||
Specify the path to the file that contains the email to be parsed. One of in_file
|
||||
and handle must be specified.
|
||||
|
||||
=item handle
|
||||
|
||||
Specify the file handle or IO stream that contains the email to be parsed.
|
||||
|
||||
=back
|
||||
|
||||
=item attach_rfc822
|
||||
|
||||
By default, the parser will decode any embeded emails, and flatten out all the
|
||||
parts. If you prefer to leave embeded emails unparsed, pass in 1 to this option
|
||||
and the parser will treat it as an attachment.
|
||||
|
||||
=back
|
||||
|
||||
=head2 parse - Parse an email
|
||||
|
||||
Instance method. Parses the email specified by either in_file or handle. Returns
|
||||
the top level L<GT::Mail::Parts> object. Any additional parameters passed in are
|
||||
treated the same as if they were passed to the constuctor.
|
||||
|
||||
=head2 parse_head - Parse just the header of the email
|
||||
|
||||
Instance method. This method is exactly the same as parse except only the top
|
||||
level header is parsed and it's part object returned. This is useful to keep
|
||||
overhead down if you only need to know about the header of the email.
|
||||
|
||||
=head2 size - Get the size
|
||||
|
||||
Instance method. Returns the total size in bytes of the parsed unencoded email. This
|
||||
method will return undef if no email has been parsed.
|
||||
|
||||
=head2 all_parts - Get all parts
|
||||
|
||||
Instance method. Returns all the parts in the parsed email. This is a flatened
|
||||
list of the objects. Somewhat similar to what MIME::Tools does. All the parts
|
||||
still contain their sub parts.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Parse.pm,v 1.79 2004/10/23 02:16:39 brewt Exp $
|
||||
|
||||
1225
site/glist/lib/GT/Mail/Parts.pm
Normal file
1225
site/glist/lib/GT/Mail/Parts.pm
Normal file
File diff suppressed because it is too large
Load Diff
481
site/glist/lib/GT/Mail/Send.pm
Normal file
481
site/glist/lib/GT/Mail/Send.pm
Normal file
@ -0,0 +1,481 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Send
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Send.pm,v 1.53 2004/08/23 20:07:44 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::Mail::Send;
|
||||
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use GT::Socket::Client;
|
||||
use GT::Mail::POP3;
|
||||
use GT::MD5;
|
||||
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $CRLF %SENDMAIL_ERRORS $HAVE_SSL);
|
||||
|
||||
%SENDMAIL_ERRORS = (
|
||||
64 => 'EX_USAGE',
|
||||
65 => 'EX_DATAERR',
|
||||
66 => 'EX_NOINPUT',
|
||||
67 => 'EX_NOUSER',
|
||||
68 => 'EX_NOHOST',
|
||||
69 => 'EX_UNAVAILABLE',
|
||||
70 => 'EX_SOFTWARE',
|
||||
71 => 'EX_OSERR',
|
||||
72 => 'EX_OSFILE',
|
||||
73 => 'EX_CANTCREAT',
|
||||
74 => 'EX_IOERR',
|
||||
75 => 'EX_TEMPFAIL',
|
||||
76 => 'EX_PROTOCOL',
|
||||
77 => 'EX_NOPERM',
|
||||
78 => 'EX_CONFIG',
|
||||
|
||||
# This is for qmail-inject's version of sendmail
|
||||
# Nice that they are different..
|
||||
111 => 'EX_TEMPFAIL',
|
||||
100 => 'EX_USAGE',
|
||||
);
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ATTRIBS = {
|
||||
mail => undef,
|
||||
host => undef,
|
||||
port => undef,
|
||||
ssl => undef,
|
||||
from => undef,
|
||||
path => undef,
|
||||
flags => undef,
|
||||
rcpt => undef,
|
||||
user => undef,
|
||||
pass => undef,
|
||||
pbs_user => undef,
|
||||
pbs_pass => undef,
|
||||
pbs_host => undef,
|
||||
pbs_port => undef,
|
||||
pbs_auth_mode => undef,
|
||||
pbs_ssl => undef,
|
||||
debug => 0,
|
||||
};
|
||||
$ERRORS = {
|
||||
HOSTNOTFOUND => "SMTP: server '%s' was not found.",
|
||||
CONNFAILED => "SMTP: connect() failed. reason: %s",
|
||||
SERVNOTAVAIL => "SMTP: Service not available: %s",
|
||||
SSLNOTAVAIL => "SMTP: SSL connections are not available: Net::SSLeay 1.06 or greater not installed.",
|
||||
COMMERROR => "SMTP: Unspecified communications error: '%s'.",
|
||||
USERUNKNOWN => "SMTP: Local user '%s' unknown on host '%s'. Server said: %s",
|
||||
TRANSFAILED => "SMTP: Transmission of message failed: %s",
|
||||
AUTHFAILED => "SMTP: Authentication failed: %s",
|
||||
TOEMPTY => "No To: field specified.",
|
||||
NOMSG => "No message body specified",
|
||||
SENDMAILNOTFOUND => "Sendmail was not defined or not found: %s",
|
||||
NOOPTIONS => "No options were specified. Be sure to pass a hash ref to send()",
|
||||
NOTRANSPORT => "Neither sendmail nor SMTP were specified!",
|
||||
SENDMAIL => "There was a problem sending to Sendmail: (%s)",
|
||||
NOMAILOBJ => "No mail object was specified.",
|
||||
EX_USAGE => "Command line usage error",
|
||||
EX_DATAERR => "Data format error",
|
||||
EX_NOINPUT => "Cannot open input",
|
||||
EX_NOUSER => "Addressee unknown",
|
||||
EX_NOHOST => "Host name unknown",
|
||||
EX_UNAVAILABLE => "Service unavailable",
|
||||
EX_SOFTWARE => "Internal software error",
|
||||
EX_OSERR => "System error (e.g., can't fork)",
|
||||
EX_OSFILE => "Critical OS file missing",
|
||||
EX_CANTCREAT => "Can't create (user) output file",
|
||||
EX_IOERR => "Input/output error",
|
||||
EX_TEMPFAIL => "Temp failure; user is invited to retry",
|
||||
EX_PROTOCOL => "Remote error in protocol",
|
||||
EX_NOPERM => "Permission denied",
|
||||
EX_CONFIG => "Configuration error",
|
||||
EX_UNKNOWN => "Sendmail exited with an unknown exit status: %s"
|
||||
};
|
||||
$CRLF = "\015\012";
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->set(@_);
|
||||
|
||||
# We need either a host or a path to sendmail and an email object
|
||||
$self->{host} or $self->{path} or return $self->error("NOTRANSPORT", "FATAL");
|
||||
exists $self->{mail} or return $self->error("NOMAILOBJ", "FATAL");
|
||||
|
||||
# Set debugging
|
||||
$self->{_debug} = defined($self->{debug}) ? $self->{debug} : $DEBUG;
|
||||
|
||||
# Default port for smtp
|
||||
if ($self->{host} and !$self->{port}) {
|
||||
$self->{port} = $self->{ssl} ? 465 : 25;
|
||||
}
|
||||
|
||||
# Default flags for sendmail
|
||||
elsif ($self->{path}) {
|
||||
($self->{flags}) or $self->{flags} = '-t -oi -oeq';
|
||||
$self->{path} =~ /^\s*(.+?)\s*$/ and $self->{path} = $1; # Untaint
|
||||
(-e $self->{path}) or return $self->error('SENDMAILNOTFOUND', 'FATAL', $1);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub smtp_send {
|
||||
# ---------------------------------------------------------------
|
||||
#
|
||||
my ($self, $sock, $cmd) = @_;
|
||||
|
||||
if (defined $cmd) {
|
||||
print $sock "$cmd$CRLF";
|
||||
$self->debug("SMTP Log: >> $cmd\n") if $self->{debug} > 1;
|
||||
}
|
||||
|
||||
$_ = <$sock>;
|
||||
return if !$_;
|
||||
|
||||
my $resp = $_;
|
||||
if (/^\d{3}-/) {
|
||||
while (defined($_ = <$sock>) and /^\d{3}-/) {
|
||||
$resp .= $_;
|
||||
}
|
||||
$resp .= $_;
|
||||
}
|
||||
$resp =~ s/$CRLF/\n/g;
|
||||
$self->debug("SMTP Log: << $resp") if $self->{debug} > 1;
|
||||
return $resp;
|
||||
}
|
||||
|
||||
sub smtp {
|
||||
# ---------------------------------------------------------------
|
||||
# Opens a smtp port and sends the message headers.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
ref $self or $self = $self->new(@_);
|
||||
|
||||
if ($self->{ssl}) {
|
||||
$HAVE_SSL ||= eval { require Net::SSLeay; Net::SSLeay->require_version(1.06); 1 };
|
||||
$HAVE_SSL or return $self->error('SSLNOTAVAIL', 'FATAL');
|
||||
}
|
||||
|
||||
if ($self->{pbs_host}) {
|
||||
my $pop = GT::Mail::POP3->new(
|
||||
host => $self->{pbs_host},
|
||||
port => $self->{pbs_port},
|
||||
user => $self->{pbs_user},
|
||||
pass => $self->{pbs_pass},
|
||||
auth_mode => $self->{pbs_auth_mode},
|
||||
ssl => $self->{pbs_ssl},
|
||||
debug => $self->{debug}
|
||||
);
|
||||
my $count = $pop->connect();
|
||||
if (!defined($count)) {
|
||||
$self->debug("Couldn't connect to server for POP3 before SMTP authentication: $GT::Mail::POP3::error") if $self->{debug};
|
||||
}
|
||||
else {
|
||||
$pop->quit();
|
||||
}
|
||||
}
|
||||
|
||||
my $sock = GT::Socket::Client->open(
|
||||
host => $self->{host},
|
||||
port => $self->{port},
|
||||
ssl => $self->{ssl}
|
||||
) or return $self->error("CONNFAILED", "WARN", GT::Socket::Client->error);
|
||||
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
local $_;
|
||||
|
||||
# Get the server's greeting message
|
||||
my $resp = $self->smtp_send($sock) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, "EHLO localhost") or return $self->error('COMMERROR', 'WARN');
|
||||
if ($resp =~ /^[45]/) {
|
||||
$resp = $self->smtp_send($sock, "HELO localhost") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
|
||||
# Authenticate if needed
|
||||
if ($resp =~ /AUTH[ =](.*)/ and $self->{user}) {
|
||||
my $server = uc $1;
|
||||
my $method = '';
|
||||
# These are the authentication types that are supported, ordered by preference
|
||||
for my $m (qw/CRAM-MD5 PLAIN LOGIN/) {
|
||||
if ($server =~ /$m/) {
|
||||
$method = $m;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($method eq 'CRAM-MD5') {
|
||||
$resp = $self->smtp_send($sock, "AUTH CRAM-MD5") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
my ($challenge) = $resp =~ /\d{3}\s+(.*)/;
|
||||
$challenge = decode_base64($challenge);
|
||||
my $auth = encode_base64("$self->{user} " . hmac_md5_hex($challenge, $self->{pass}));
|
||||
|
||||
$resp = $self->smtp_send($sock, $auth) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
elsif ($method eq 'PLAIN') {
|
||||
my $auth = encode_base64("$self->{user}\0$self->{user}\0$self->{pass}");
|
||||
$resp = $self->smtp_send($sock, "AUTH PLAIN $auth") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
elsif ($method eq 'LOGIN') {
|
||||
$resp = $self->smtp_send($sock, "AUTH LOGIN") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, encode_base64($self->{user})) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, encode_base64($self->{pass})) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
}
|
||||
|
||||
# We use return-path so the email will bounce to who it's from, not the user
|
||||
# doing the sending.
|
||||
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
||||
$from = $self->extract_email($from) || '';
|
||||
|
||||
$self->debug("Sending from: <$from>") if $self->{debug} == 1;
|
||||
$resp = $self->smtp_send($sock, "MAIL FROM: <$from>") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
my $found_valid = 0;
|
||||
my @tos = ($self->{mail}->{head}->split_field('to'), $self->{mail}->{head}->split_field('bcc'), $self->{mail}->{head}->split_field('cc'));
|
||||
for my $to (@tos) {
|
||||
next unless $to and my $email = $self->extract_email($to);
|
||||
|
||||
$found_valid++;
|
||||
$self->debug("Sending RCPT TO: <$email>.") if $self->{debug} == 1;
|
||||
$resp = $self->smtp_send($sock, "RCPT TO: <$email>") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('USERUNKNOWN', 'WARN', $email, $self->{host}, $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
$found_valid or return $self->error('TOEMPTY', 'FATAL');
|
||||
|
||||
$resp = $self->smtp_send($sock, "DATA") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
# Remove Bcc from the headers.
|
||||
my @bcc = $self->{mail}->{head}->delete('bcc');
|
||||
|
||||
my $mail = $self->{mail}->to_string;
|
||||
|
||||
# SMTP needs any leading .'s to be doubled up.
|
||||
$mail =~ s/^\./../gm;
|
||||
|
||||
# Print the mail body.
|
||||
$resp = $self->smtp_send($sock, $mail . $CRLF . '.') or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('TRANSFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
# Add them back in.
|
||||
foreach my $bcc (@bcc) {
|
||||
$self->{mail}->{head}->set('bcc', $bcc);
|
||||
}
|
||||
|
||||
# Close the connection.
|
||||
$resp = $self->smtp_send($sock, "QUIT") or return $self->error('COMMERROR', 'WARN');
|
||||
close $sock;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub sendmail {
|
||||
# ---------------------------------------------------------------
|
||||
# Sends a message using sendmail.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
ref $self or $self = $self->new(@_);
|
||||
|
||||
# Get a filehandle, and open pipe to sendmail.
|
||||
my $s = \do{ local *FH; *FH };
|
||||
|
||||
# If the email address is safe, we set the envelope via -f so bounces are handled properly.
|
||||
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
||||
my $envelope = '';
|
||||
if ($from =~ /<?([\w\-\.]+\@[\w\-\.]+)>?/) {
|
||||
$envelope = "-f $1";
|
||||
}
|
||||
elsif ($from eq '<>' or $from eq '') {
|
||||
$envelope = "-f ''";
|
||||
}
|
||||
open($s, "|$self->{path} $self->{flags} $envelope 1>&2") or return $self->error("SENDMAIL", "WARN", "$!");
|
||||
$self->{mail}->write($s);
|
||||
return 1 if close $s;
|
||||
my $exit_value = $? >> 8;
|
||||
|
||||
my $code;
|
||||
if (exists $SENDMAIL_ERRORS{$exit_value}) {
|
||||
$code = $SENDMAIL_ERRORS{$exit_value};
|
||||
}
|
||||
else {
|
||||
$code = 'EX_UNKNOWN';
|
||||
}
|
||||
if ($code eq 'EX_TEMPFAIL') {
|
||||
return 1;
|
||||
}
|
||||
return $self->error($code, "WARN", $exit_value);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub extract_email {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a field, returns the e-mail address contained in that field, or undef
|
||||
# if no e-mail address could be found.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
|
||||
my $to = shift;
|
||||
|
||||
# We're trying to get down to the actual e-mail address. To do so, we have to
|
||||
# remove quoted strings and comments, then extract the e-mail from whatever is
|
||||
# left over.
|
||||
$to =~ s/"(?:[^"\\]|\\.)*"//g;
|
||||
1 while $to =~ s/\((?:[^()\\]|\\.)*\)//sg;
|
||||
|
||||
my ($email) = $to =~ /([^<>\s]+\@[\w.-]+)/;
|
||||
|
||||
return $email;
|
||||
}
|
||||
|
||||
sub encode_base64 {
|
||||
my $res = '';
|
||||
pos($_[0]) = 0; # In case something has previously adjusted pos
|
||||
while ($_[0] =~ /(.{1,45})/gs) {
|
||||
$res .= substr(pack(u => $1), 1, -1);
|
||||
}
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;
|
||||
|
||||
my $padding = (3 - length($_[0]) % 3) % 3;
|
||||
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
|
||||
$res;
|
||||
}
|
||||
|
||||
sub decode_base64 {
|
||||
my $str = shift;
|
||||
my $res = '';
|
||||
|
||||
$str =~ tr|A-Za-z0-9+=/||cd;
|
||||
|
||||
$str =~ s/=+$//;
|
||||
$str =~ tr|A-Za-z0-9+/| -_|;
|
||||
return '' unless length $str;
|
||||
|
||||
my $uustr = '';
|
||||
my ($i, $l);
|
||||
$l = length($str) - 60;
|
||||
for ($i = 0; $i <= $l; $i += 60) {
|
||||
$uustr .= "M" . substr($str, $i, 60);
|
||||
}
|
||||
$str = substr($str, $i);
|
||||
# and any leftover chars
|
||||
if ($str ne "") {
|
||||
$uustr .= chr(32 + length($str) * 3 / 4) . $str;
|
||||
}
|
||||
return unpack("u", $uustr);
|
||||
}
|
||||
|
||||
sub hmac_md5_hex {
|
||||
my ($challenge, $data) = @_;
|
||||
|
||||
GT::MD5::md5($challenge) if length $challenge > 64;
|
||||
|
||||
my $ipad = $data ^ (chr(0x36) x 64);
|
||||
my $opad = $data ^ (chr(0x5c) x 64);
|
||||
|
||||
return GT::MD5::md5_hex($opad, GT::MD5::md5($ipad, $challenge));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Send - Module to send emails
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Send;
|
||||
|
||||
# $mail_object must be a GT::Mail object
|
||||
my $send = new GT::Mail::Send (
|
||||
mail => $mail_object,
|
||||
host => 'smtp.gossamer-threads.com',
|
||||
debug => 1
|
||||
);
|
||||
|
||||
$send->smtp or die $GT::Mail::Send::error;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Send is an object interface to sending email over either
|
||||
SMTP or Sendmail. This module is used internally to GT::Mail.
|
||||
|
||||
=head2 new - Constructor method
|
||||
|
||||
Returns a new GT::Mail::Send object. You must specify either the smtp host
|
||||
or a path to sendmail. This method is inherented from GT::Base. The arguments
|
||||
can be in the form of a hash or hash ref.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this instance of GT::Mail::Send.
|
||||
|
||||
=item mail
|
||||
|
||||
Specify the mail object to use. This must be a GT::Mail object and must contain
|
||||
an email, either passed in or parsed in.
|
||||
|
||||
=item host
|
||||
|
||||
Specify the host to use when sending by SMTP.
|
||||
|
||||
=item port
|
||||
|
||||
Specify the port to use when sending over SMTP. Defaults to 25.
|
||||
|
||||
=item path
|
||||
|
||||
Specify the path to sendmail when sending over sendmail. If the binary passed in
|
||||
does not exist, undef will be returned and the error set in GT::Mail::Send::error.
|
||||
|
||||
=item flags
|
||||
|
||||
Specify the flags used to call sendmail. Defaults to -t -oi -oeq, see the Sendmail
|
||||
guilde for sendmail for more info on the parameters to sendmail.
|
||||
|
||||
=back
|
||||
|
||||
=head2 smtp
|
||||
|
||||
Class or instance method. Sends the passed in email over SMTP. If called as a class
|
||||
method, the parameters passed in will be used to call new(). Returns true on error,
|
||||
false otherwise.
|
||||
|
||||
=head2 sendmail
|
||||
|
||||
Class or instance method. Send the passed in email to sendmail using the specified
|
||||
path and flags. If called as a class method all additional arguments are passed to the
|
||||
new() method. Returns true on success and false otherwise.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Send.pm,v 1.53 2004/08/23 20:07:44 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
424
site/glist/lib/GT/Plugins.pm
Normal file
424
site/glist/lib/GT/Plugins.pm
Normal file
@ -0,0 +1,424 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Plugins.pm,v 1.55 2005/04/01 00:16:51 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A plugin system for CGI scripts.
|
||||
#
|
||||
|
||||
package GT::Plugins;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
# TODO: Eventually we want to get rid of the $ACTION global, but it would break
|
||||
# rather a lot to do so.
|
||||
use vars qw/$VERSION $DEBUG $ERRORS $ATTRIBS $ACTION $error @ISA $AUTOLOAD @EXPORT/;
|
||||
use GT::Base;
|
||||
use GT::Config;
|
||||
use GT::AutoLoader;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$ERRORS = {
|
||||
BADARGS => "Invalid arguments. Usage: %s",
|
||||
CANTLOAD => "Unable to load plugin '%s': %s",
|
||||
CANTOPEN => "Unable to open '%s': %s",
|
||||
CANTDELETE => "Unable to remove plugin file '%s': %s",
|
||||
CANTMOVE => "Unable to move plugin %s from '%s' to '%s': %s",
|
||||
CANTREMOVE => "Unable to remove plugin file '%s': %s",
|
||||
PLUGEXISTS => "The plugin '%s' already exists, unable to overwrite without confirmation",
|
||||
NOINSTALL => "Unable to load install code in plugin '%s'. Missing Install.pm file.",
|
||||
NOCODE => "Unable to load main code for plugin '%s' from tar file. Missing '%s.pm' file.",
|
||||
NOPLUGINNAME => "Please name your plugin before calling save()",
|
||||
NOPLUGIN => "There is no plugin named '%s' in the config file.",
|
||||
CORRUPTCFG => "Syntax error in config file: %s",
|
||||
PLUGINERR => "Error running plugin '%s' hook '%s': %s"
|
||||
};
|
||||
$ATTRIBS = { directory => undef, prefix => '' };
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
# Actions that plugins can handle.
|
||||
use constants
|
||||
STOP => 1,
|
||||
CONTINUE => 2,
|
||||
|
||||
NAME => 0,
|
||||
TYPE => 1,
|
||||
HOOK => 2,
|
||||
ENABLED => 3;
|
||||
|
||||
@EXPORT = qw/STOP CONTINUE/;
|
||||
|
||||
sub init {
|
||||
# -----------------------------------------------------------------
|
||||
# Set our debug level and any extra options.
|
||||
#
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
if (@args == 1 and not ref $args[0]) {
|
||||
@args = (directory => @args);
|
||||
}
|
||||
|
||||
$self->set(@args);
|
||||
|
||||
if ($self->{debug}) {
|
||||
$self->{_debug} = delete $self->{debug};
|
||||
}
|
||||
|
||||
$self->{directory} or $self->fatal(BADARGS => 'No directory passed to GT::Plugins->new()');
|
||||
|
||||
$self->load_cfg;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub active_plugins {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Class/object method that returns a boolean value indicating whether or not
|
||||
# the given argument (a plugin hook name) has any registered plugin hooks.
|
||||
# Primarily designed for optimizations where a section of code isn't needed
|
||||
# except for plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg(shift);
|
||||
|
||||
my $hook_name = lc shift;
|
||||
|
||||
return (
|
||||
exists $config->{_pre_hooks}->{$hook_name} and @{$config->{_pre_hooks}->{$hook_name}} or
|
||||
exists $config->{_post_hooks}->{$hook_name} and @{$config->{_post_hooks}->{$hook_name}}
|
||||
) ? 1 : undef;
|
||||
}
|
||||
|
||||
sub dispatch {
|
||||
# -----------------------------------------------------------------
|
||||
# Class Method to Run plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $directory;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg($directory = shift);
|
||||
my ($hook_name, $code, @args) = @_;
|
||||
|
||||
$hook_name = lc $hook_name;
|
||||
|
||||
# Run any pre hooks.
|
||||
my @results;
|
||||
my $debug = ref $self ? $self->{_debug} : $DEBUG;
|
||||
|
||||
if (exists $config->{_pre_hooks}->{$hook_name}) {
|
||||
local $^W; no strict 'refs';
|
||||
# Save our action in case plugins is called twice.
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_pre_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: pre $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'PRE') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->(@args);
|
||||
if ($ACTION == STOP) {
|
||||
$self->debug("Plugin pre hook $hook_name stopped further plugins.") if $debug;
|
||||
last;
|
||||
}
|
||||
}
|
||||
unless ($ACTION == STOP) {
|
||||
@results = $code->(@args);
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
else {
|
||||
@results = $code->(@args);
|
||||
}
|
||||
|
||||
# Run any post hooks.
|
||||
if (exists $config->{_post_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_post_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: post $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'POST') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->(@results);
|
||||
if ($ACTION == STOP) {
|
||||
$self->debug("Plugin post hook $hook_name stopped further plugins.") if $debug;
|
||||
last;
|
||||
}
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
|
||||
# Must return as a list
|
||||
return @results ? (@results)[0 .. $#results] : ();
|
||||
}
|
||||
|
||||
sub dispatch_method {
|
||||
# -----------------------------------------------------------------
|
||||
# Class Method to Run plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $directory;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg($directory = shift);
|
||||
my ($hook_name, $object, $method, @args) = @_;
|
||||
$hook_name = lc $hook_name;
|
||||
|
||||
my $debug = ref $self ? $self->{_debug} : $DEBUG;
|
||||
|
||||
# Run any pre hooks.
|
||||
my @results;
|
||||
if (exists $config->{_pre_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
# Save our action in case plugins is called twice.
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_pre_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: pre $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'PRE') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->($object, @args);
|
||||
$ACTION == STOP and last;
|
||||
}
|
||||
unless ($ACTION == STOP) {
|
||||
@results = $object->$method(@args);
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
else {
|
||||
@results = $object->$method(@args);
|
||||
}
|
||||
|
||||
# Run any post hooks.
|
||||
if (exists $config->{_post_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_post_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: post $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'POST') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->($object, @results);
|
||||
# If the post hook returned the object as the first return value
|
||||
# that probably means it returned @_ unaltered, in which case we
|
||||
# want to remove it so that @results doesn't end up with any number
|
||||
# of objects stuck to the beginning of arguments/return values.
|
||||
shift @results if ref $object and ref $results[0] and $object == $results[0];
|
||||
|
||||
$ACTION == STOP and last;
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
|
||||
# Must return as a list
|
||||
return @results ? (@results)[0 .. $#results] : ();
|
||||
}
|
||||
|
||||
sub load_cfg {
|
||||
# -----------------------------------------------------------------
|
||||
# Load the plugin config file.
|
||||
#
|
||||
my ($self, $directory) = @_;
|
||||
$directory ||= ref $self ? $self->{directory} : '.';
|
||||
|
||||
my $cfg = GT::Config->load("$directory/plugin.cfg", { local => 0, inheritance => 0, create_ok => 1 });
|
||||
|
||||
if (!$cfg and ref $self ? $self->{_debug} : $DEBUG) {
|
||||
$self->debug("Unable to load plugin config file '$directory/plugin.cfg': $GT::Config::error");
|
||||
}
|
||||
|
||||
# Take care to delete _pre_hooks just in case the file was somehow saved
|
||||
# with _pre_hooks in it.
|
||||
delete $cfg->{_pre_hooks} if not $cfg->cache_hit;
|
||||
|
||||
# If _pre_hooks exists, the config was loaded from the cache, and the below
|
||||
# has already been calculated.
|
||||
unless ($cfg->{_pre_hooks}) {
|
||||
$cfg->{_pre_hooks} = {};
|
||||
$cfg->{_post_hooks} = {};
|
||||
while (my ($plugin, $config) = each %$cfg) {
|
||||
next if substr($plugin, 0, 1) eq '_' or ref $config->{hooks} ne 'ARRAY';
|
||||
for my $hook (@{$config->{hooks}}) {
|
||||
next unless $hook->[ENABLED] and ($hook->[TYPE] eq 'PRE' or $hook->[TYPE] eq 'POST');
|
||||
push @{$cfg->{$hook->[TYPE] eq 'PRE' ? '_pre_hooks' : '_post_hooks'}->{lc $hook->[NAME]}}, $hook->[HOOK];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self->{config} = $cfg if ref $self;
|
||||
return $cfg;
|
||||
}
|
||||
|
||||
$COMPILE{save_cfg} = __LINE__ . <<'END_OF_SUB';
|
||||
sub save_cfg {
|
||||
# -----------------------------------------------------------------
|
||||
# Save the plugin cfg file. OO usage: $plugin_obj->save; Deprecated, non-OO
|
||||
# usage: GT::Plugins->save_cfg($plugin_config_object); Also supported is:
|
||||
# GT::Plugins->save_cfg($ignored_value, $plugin_config_object); for
|
||||
# compatibility reasons. These are almost equivelant to
|
||||
# $plugin_config_object->save, except that they remove the internal _pre_hooks
|
||||
# and _post_hooks keys first, then restore them after saving.
|
||||
#
|
||||
my $self = shift;
|
||||
my $config = ref $self ? $self->{config} : @_ > 1 ? $_[1] : $_[0];
|
||||
|
||||
my ($pre, $post) = delete @$config{qw/_pre_hooks _post_hooks/};
|
||||
|
||||
$config->save();
|
||||
|
||||
@$config{qw/_pre_hooks _post_hooks/} = ($pre, $post);
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub action {
|
||||
# -------------------------------------------------------------------
|
||||
# Sets the action the plugin wants.
|
||||
#
|
||||
$ACTION = $_[1];
|
||||
}
|
||||
|
||||
$COMPILE{_load_hook} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _load_hook {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a module and checks for the hook.
|
||||
#
|
||||
my ($self, $hook, $stage) = @_;
|
||||
my ($pkg) = $hook =~ /^(.*)::[^:]+$/ or return;
|
||||
$pkg =~ s,::,/,g;
|
||||
{
|
||||
local $SIG{__DIE__};
|
||||
eval { require "$pkg.pm" };
|
||||
}
|
||||
if ($@) {
|
||||
return $self->error('PLUGINERR', 'FATAL', $stage, $hook, "$@");
|
||||
}
|
||||
if (! defined &{$hook}) {
|
||||
return $self->error('PLUGINERR', 'FATAL', $stage, $hook, "$hook does not exist in $pkg");
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{reset_env} = __LINE__ . <<'END_OF_SUB';
|
||||
sub reset_env { }
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Plugins - a plugin interface for Gossamer Threads products.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Plugins;
|
||||
$PLUGIN = GT::Plugins->new('/path/to/plugin/dir');
|
||||
|
||||
$PLUGIN->dispatch(hook_name => \&code_ref => @args);
|
||||
$PLUGIN->dispatch_method(hook_name => $self => method => @args);
|
||||
|
||||
Old style, now deprecated in favour of the object approach above:
|
||||
|
||||
use GT::Plugins;
|
||||
|
||||
GT::Plugins->dispatch('/path/to/plugin/dir', hook_name => \&code_ref => @args);
|
||||
GT::Plugins->dispatch_method('/path/to/plugin/dir', hook_name => $self => method => @args);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The plugin module supports two modes of use. The first mode involves creating
|
||||
and using a GT::Plugins object upon which plugin dispatch methods may be called
|
||||
to provide hooks. The second does not use the object, but instead uses class
|
||||
methods with an extra argument of the plugin path preceding the other
|
||||
->dispatch() arguments.
|
||||
|
||||
Of the two approaches, the object approach is recommended as it is a) faster,
|
||||
and b) requires much less value duplication as the plugin directory needs to be
|
||||
specified only once. The old, class-method-based plugin interface should be
|
||||
considered deprecated, and all new code should attempt to use the object-based
|
||||
system.
|
||||
|
||||
A dispatch with each of the two interfaces work as follows, with differences in
|
||||
interfaces as noted:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Loads the plugin config file. The actual file access and evaluation will be
|
||||
cached, but a small amount of extra overhead is required on each dispatch.
|
||||
This only applies to the deprecated class-method dispatch interface - the
|
||||
preferred object interface loads the configuration file only once.
|
||||
|
||||
=item 2.
|
||||
|
||||
Runs any 'PRE' hooks registered in the config file. When using ->dispatch(),
|
||||
each hook is passed the C<@args> arguments passed into ->dispatch. When using
|
||||
->dispatch_method(), both the object ($self) and arguments (@args) are passed
|
||||
to the hook.
|
||||
|
||||
Each plugin hook then has the ability to abort further plugins if desired by
|
||||
calling C<$PLUGIN-E<gt>action(STOP)> (or C<GT::Plugins-E<gt>action(STOP)> for
|
||||
the non-OO interface). STOP is exported by default from the GT::Plugins
|
||||
module. Performing a STOP will skip both any further 'PRE' hooks and the
|
||||
original function/method, and will use the hook's return value instead of the
|
||||
real code's return value.
|
||||
|
||||
The current behaviour of 'PRE' hooks ignores the return value of any 'PRE' hook
|
||||
that does not perform a STOP, however this behaviour B<may> change to use the
|
||||
return value as the arguments to the next PRE hook or actual code called. As
|
||||
such, it is strongly recommended to return @_ from any 'PRE' hooks.
|
||||
|
||||
=item 3.
|
||||
|
||||
Assuming C<-E<gt>action(STOP)> has not been called, the method
|
||||
(->dispatch_method) or code reference (->dispatch) will be called, and its
|
||||
return value stored.
|
||||
|
||||
=item 4.
|
||||
|
||||
Any registered 'POST' hooks registered in the config file will be run. When
|
||||
using ->dispatch(), the list-context return value of the main code run (or, if
|
||||
a 'PRE' hook called STOP, the return value of that 'PRE' hook) will be passed
|
||||
in. When using ->dispatch_method(), the object is additionally passed in as
|
||||
the first argument.
|
||||
|
||||
The list returned by the 'POST' hook will be used as arguments for any
|
||||
subsequent 'POST' hooks and as the final result returned by the ->dispatch() or
|
||||
->dispatch_method() call. There is one exception to this - for
|
||||
->dispatch_method() 'POST' hooks, if the first argument of the return value is
|
||||
the object, it will be removed; this is done to prevent a build-up of excess
|
||||
objects at the beginning of the 'POST' hook arguments/return values due to
|
||||
'POST' hooks simply returning @_ unaltered.
|
||||
|
||||
=item 5.
|
||||
|
||||
The return value of the final 'POST' hook, or, when no post hooks are
|
||||
configured, of the actual code, is returned as the result of the ->dispatch()
|
||||
call.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Also included as part of the plugin system are some modules for web based tools
|
||||
to manage plugins:
|
||||
|
||||
L<GT::Plugins::Manager> - Add, remove and edit plugin files.
|
||||
|
||||
L<GT::Plugins::Wizard> - Create shell plugins.
|
||||
|
||||
L<GT::Plugins::Installer> - Used in installing plugins.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Plugins.pm,v 1.55 2005/04/01 00:16:51 brewt Exp $
|
||||
|
||||
=cut
|
||||
837
site/glist/lib/GT/Plugins/Author.pm
Normal file
837
site/glist/lib/GT/Plugins/Author.pm
Normal file
@ -0,0 +1,837 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Author.pm,v 1.14 2004/01/13 01:35:18 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A web based admin to package new plugins.
|
||||
#
|
||||
|
||||
package GT::Plugins::Author;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use lib '../..';
|
||||
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $ERRORS $DEBUG $PLUGIN_DIR $FONT/;
|
||||
use GT::Base;
|
||||
use GT::Plugins;
|
||||
use GT::Template;
|
||||
use GT::Dumper;
|
||||
use GT::Tar;
|
||||
|
||||
$ATTRIBS = {
|
||||
plugin_name => '',
|
||||
prefix => '',
|
||||
version => '',
|
||||
meta => {},
|
||||
pre_install => '',
|
||||
install => '',
|
||||
pre_uninstall => '',
|
||||
uninstall => '',
|
||||
header => '',
|
||||
admin_menu => [],
|
||||
options => {},
|
||||
hooks => [],
|
||||
cfg => undef,
|
||||
tar => undef
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::Plugins';
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.14 $ =~ /(\d+)\.(\d+)/;
|
||||
$FONT = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
||||
|
||||
sub init {
|
||||
# ------------------------------------------------------------------
|
||||
# Create a new plugin author object, called from GT::Base on new().
|
||||
#
|
||||
my $self = shift;
|
||||
if (! defined $PLUGIN_DIR) {
|
||||
$PLUGIN_DIR = shift or return $self->error('BADARGS', 'FATAL', "new GT::Plugins::Author ( '/path/to/plugin/dir' )");
|
||||
$PLUGIN_DIR .= $PLUGIN_DIR =~ m,/$, ? "Plugins" : "/Plugins";
|
||||
}
|
||||
$self->{cfg} = GT::Plugins->load_cfg($PLUGIN_DIR);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub list_editable {
|
||||
# ------------------------------------------------------------------
|
||||
# List current plugin names available to be edited.
|
||||
#
|
||||
my $self = shift;
|
||||
my $dir = $PLUGIN_DIR . "/Author";
|
||||
my @projects = ();
|
||||
|
||||
opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!);
|
||||
while (defined(my $file = readdir(DIR))) {
|
||||
next unless ($file =~ /(.*)\.tar$/);
|
||||
push @projects, $1;
|
||||
}
|
||||
closedir(DIR);
|
||||
return \@projects;
|
||||
}
|
||||
|
||||
sub load_plugin {
|
||||
# ------------------------------------------------------------------
|
||||
# Load a plugin tar file into self.
|
||||
#
|
||||
my ($self, $plugin_name) = @_;
|
||||
$self->{plugin_name} = $plugin_name;
|
||||
$self->{tar} = $self->_load_tar or return;
|
||||
$self->_load_plugin;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub save {
|
||||
# ------------------------------------------------------------------
|
||||
# Save the current state of self into tar file.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{plugin_name} or return $self->error('NOPLUGINNAME', 'WARN');
|
||||
|
||||
|
||||
my ($author);
|
||||
$self->{tar} or $self->_load_tar;
|
||||
foreach my $file ($self->{tar}->files) {
|
||||
if ($file->name =~ /Author\.pm$/) {
|
||||
$author = $file;
|
||||
}
|
||||
}
|
||||
$author ?
|
||||
($author->body( $self->_create_author )) :
|
||||
($author = $self->{tar}->add_data( name => 'Author.pm', body => $self->_create_author ));
|
||||
|
||||
# add files.
|
||||
return $self->{tar}->write();
|
||||
}
|
||||
|
||||
sub add_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the Install.pm file.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $self->{tar}->get_file('Install.pm');
|
||||
if ($file) {
|
||||
$self->_replace_install($file);
|
||||
}
|
||||
else {
|
||||
my $time = localtime();
|
||||
my $version = $self->{version} || 0;
|
||||
my $meta_dump = GT::Dumper->dump( var => '$META', data => $self->{meta} );
|
||||
|
||||
my $output = <<END_OF_PLUGIN;
|
||||
# ==================================================================
|
||||
# $self->{prefix}Plugins::$self->{plugin_name} - Auto Generated Install Module
|
||||
#
|
||||
# $self->{prefix}Plugins::$self->{plugin_name}
|
||||
# Author : $self->{meta}->{author}
|
||||
# Version : $self->{version}
|
||||
# Updated : $time
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package $self->{prefix}Plugins::$self->{plugin_name};
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/\$VERSION \$DEBUG \$NAME \$META/;
|
||||
\$VERSION = $version;
|
||||
\$DEBUG = 0;
|
||||
\$NAME = '$self->{plugin_name}';
|
||||
$meta_dump
|
||||
$self->{header}
|
||||
|
||||
$self->{install}
|
||||
$self->{uninstall}
|
||||
$self->{pre_install}
|
||||
$self->{pre_uninstall}
|
||||
|
||||
1;
|
||||
|
||||
END_OF_PLUGIN
|
||||
$self->{tar}->add_data( name => 'Install.pm', body => $output );
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# HTML Generationg Methods #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub attribs_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns a hash of attribs as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = {
|
||||
plugin => $self->{plugin},
|
||||
version => $self->{version},
|
||||
meta => $self->meta_as_html,
|
||||
install => $self->install_as_html,
|
||||
hooks => $self->hooks_as_html,
|
||||
admin_menu => $self->admin_menu_as_html,
|
||||
options => $self->options_as_html,
|
||||
files => $self->files_as_html,
|
||||
};
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub attribs_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns a hash of attribs in form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = {
|
||||
plugin => $self->{plugin},
|
||||
version => $self->{version},
|
||||
meta => $self->meta_as_form,
|
||||
install => $self->install_as_form,
|
||||
hooks => $self->hooks_as_form,
|
||||
admin_menu => $self->admin_menu_as_form,
|
||||
options => $self->options_as_form,
|
||||
files => $self->files_as_form,
|
||||
};
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub attribs_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Load author from a cgi object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->meta_from_cgi($cgi);
|
||||
$self->install_from_cgi($cgi);
|
||||
$self->hooks_from_cgi($cgi);
|
||||
$self->admin_menu_from_cgi($cgi);
|
||||
$self->options_from_cgi($cgi);
|
||||
$self->files_from_cgi($cgi);
|
||||
}
|
||||
|
||||
sub meta_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = qq~
|
||||
<tr><td><$FONT>Version:</font></td><td><$FONT>~ . _escape_html($self->{version}) . qq~</font></td></tr>
|
||||
<tr><td><$FONT>Author:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{author}) . qq~</font></td></tr>
|
||||
<tr><td><$FONT>URL:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{url}) . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Description:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{description}) . qq~</font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub meta_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = qq~
|
||||
<tr><td><$FONT>Version:</font></td><td><$FONT><input type="text" name="version" value="~ . _escape_html($self->{version}) . qq~"></font></td></tr>
|
||||
<tr><td><$FONT>Author:</font></td><td><$FONT><input type="text" name="author" value="~ . _escape_html($self->{meta}->{author}) . qq~"></font></td></tr>
|
||||
<tr><td><$FONT>URL:</font></td><td><$FONT><input type="text" name="url" value="~ . _escape_html($self->{meta}->{url}) . qq~"></font></td></tr>
|
||||
<tr><td valign="top"><$FONT>Description:</font></td><td><$FONT><textarea cols=50 rows=5 name="description">~ . _escape_html($self->{meta}->{description}) . qq~</textarea></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub meta_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Takes meta information from CGI object and stores it in self.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->{version} = $cgi->param('version');
|
||||
$self->{meta}->{author} = $cgi->param('author');
|
||||
$self->{meta}->{url} = $cgi->param('url');
|
||||
$self->{meta}->{description} = $cgi->param('description');
|
||||
}
|
||||
|
||||
sub install_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns the install information as html.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->_load_install;
|
||||
my $output = qq~
|
||||
<tr><td valign=top><$FONT>Pre Install Message:</font></td><td><$FONT>~ . ($self->{pre_install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Post Install Message:</font></td><td><$FONT>~ . ($self->{pre_uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Install Code:</font></td><td><$FONT>~ . ($self->{install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Uninstall Code:</font></td><td><$FONT>~ . ($self->{uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub install_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns the install information as a form.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->_load_install;
|
||||
my $output = qq~
|
||||
<tr><td valign=top><$FONT>Pre Install Message:<br>
|
||||
<input type="submit" name="preinst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_install">~ . _escape_html($self->{pre_install}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Post Install Message:<br>
|
||||
<input type="submit" name="preuninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_uninstall">~ . _escape_html($self->{pre_uninstall}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Install Code:<br>
|
||||
<input type="submit" name="inst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="install">~ . _escape_html($self->{install}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Uninstall Code:<br>
|
||||
<input type="submit" name="uninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 wrap="off" rows=8 name="uninstall">~ . _escape_html($self->{uninstall}) . qq~</textarea></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub install_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the install information from a CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
|
||||
if ($cgi->param('inst_auto_generate')) {
|
||||
$self->{install} = $self->_create_install;
|
||||
}
|
||||
elsif ($cgi->param('preinst_auto_generate')) {
|
||||
$self->{pre_install} = $self->_create_preinstall;
|
||||
}
|
||||
elsif ($cgi->param('preuninst_auto_generate')) {
|
||||
$self->{pre_uninstall} = $self->_create_preuninstall;
|
||||
}
|
||||
elsif ($cgi->param('uninst_auto_generate')) {
|
||||
$self->{uninstall} = $self->_create_uninstall;
|
||||
}
|
||||
else {
|
||||
$self->{pre_install} = $cgi->param('pre_install');
|
||||
$self->{pre_uninstall} = $cgi->param('pre_uninstall');
|
||||
$self->{install} = $cgi->param('install');
|
||||
$self->{uninstall} = $cgi->param('uninstall');
|
||||
}
|
||||
}
|
||||
|
||||
sub hooks_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns plugin hooks as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{hooks}}) {
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
my ($hook_name, $prepost, $code) = @$hook;
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$hook_name ($prepost)</font></td><td><$FONT>$code</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No hooks installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub hooks_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns plugin hooks as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{hooks}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Hooks</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
my ($hook_name, $prepost, $code) = @$hook;
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$hook_name ($prepost) => $code</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_hooks" value="$i"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
my $pkg = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::";
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Hook</font></td></tr>
|
||||
<tr><td><$FONT>Hook: <input type="text" name="hook_name" size="10"> <select name="prepost"><option>PRE<option>POST</select></font></td>
|
||||
<td><$FONT>Code: <input type="text" name="code" value="$pkg"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub hooks_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the hook info based on CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_hooks');
|
||||
foreach my $delete_pos (@to_delete) {
|
||||
splice(@{$self->{hooks}}, $delete_pos, 1);
|
||||
}
|
||||
if ($cgi->param('hook_name')) {
|
||||
my ($name, $prepost, $code) = ($cgi->param('hook_name'), uc $cgi->param('prepost'), $cgi->param('code'));
|
||||
push @{$self->{hooks}}, [$name, $prepost, $code];
|
||||
}
|
||||
}
|
||||
|
||||
sub admin_menu_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{admin_menu}}) {
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
my $menu_name = _escape_html($menu->[0]);
|
||||
my $menu_url = _escape_html($menu->[1]);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$menu_name</font></td><td><$FONT>=> $menu_url</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No Admin Menu options installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub admin_menu_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{admin_menu}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Admin Menu options</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
my $menu_name = _escape_html($menu->[0]);
|
||||
my $menu_url = _escape_html($menu->[1]);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$menu_name => $menu_url</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_admin_menu" value="$i"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Menu</font></td></tr>
|
||||
<tr><td><$FONT>Name: <input type="text" name="menu_name" size="10"></font></td>
|
||||
<td><$FONT>URL: <input type="text" name="menu_url" size="20"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub admin_menu_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the admin menu info based on CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_admin_menu');
|
||||
foreach my $delete_pos (@to_delete) {
|
||||
splice(@{$self->{admin_menu}}, $delete_pos, 1);
|
||||
}
|
||||
if ($cgi->param('menu_name')) {
|
||||
my ($name, $url) = ($cgi->param('menu_name'), $cgi->param('menu_url'));
|
||||
push @{$self->{admin_menu}}, [$name, $url];
|
||||
}
|
||||
}
|
||||
|
||||
sub options_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (keys %{$self->{options}}) {
|
||||
foreach my $key (sort keys %{$self->{options}}) {
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>~ . _escape_html($key) . qq~</font></td><td><$FONT>=> ~ . _escape_html($self->{options}->{$key}) . qq~</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No user options installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub options_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (keys %{$self->{options}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed User options</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $key (sort keys %{$self->{options}}) {
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>~ . _escape_html($key) . qq~ => ~ . _escape_html($self->{options}->{$key}) . qq~</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_options" value="~ . _escape_html($key) . qq~"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Option</font></td></tr>
|
||||
<tr><td><$FONT>Name: <input type="text" name="add_key" size="10"></font></td>
|
||||
<td><$FONT>Default: <input type="text" name="add_val" size="20"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub options_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the options based on the user input.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_options');
|
||||
foreach my $key (@to_delete) {
|
||||
delete $self->{options}->{$key};
|
||||
}
|
||||
my ($key, $value) = ($cgi->param('add_key'), $cgi->param('add_val'));
|
||||
if (defined $key and $key) {
|
||||
$self->{options}->{$key} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
sub files_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
my $num_files = 0;
|
||||
if ($self->{tar}) {
|
||||
my $files = $self->{tar}->files;
|
||||
foreach my $file (@$files) {
|
||||
my $name = $file->name;
|
||||
my $size = $file->size;
|
||||
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
||||
next if ($name =~ /Author\.pm$/);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$name</font></td><td><$FONT>$size</font></td></tr>
|
||||
~;
|
||||
$num_files++;
|
||||
}
|
||||
}
|
||||
if (! $num_files) {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No extra files installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub files_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my ($self, $edit_url) = @_;
|
||||
my $output;
|
||||
my $num_files = 0;
|
||||
if ($self->{tar}) {
|
||||
my $files = $self->{tar}->files;
|
||||
foreach my $file (@$files) {
|
||||
my $name = _escape_html($file->name);
|
||||
my $size = $file->size;
|
||||
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
||||
next if ($name =~ /Author\.pm$/);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$name</font></td><td><$FONT>($size)</font></td></tr>
|
||||
~;
|
||||
$num_files++;
|
||||
}
|
||||
}
|
||||
if ($num_files) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Files</font></td></tr>
|
||||
$output
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub files_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Set the file information.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->{tar} or $self->_load_tar;
|
||||
my $filename = $cgi->param('add_name');
|
||||
my $filehandle = $cgi->param('add_file');
|
||||
my $body = $cgi->param('add_body');
|
||||
if ($filename) {
|
||||
if (ref $filehandle) {
|
||||
my ($buffer, $read);
|
||||
while ($read = read($filehandle, $buffer, 4096)) {
|
||||
$body .= $buffer;
|
||||
}
|
||||
}
|
||||
if (! $body) {
|
||||
$body = ' ';
|
||||
}
|
||||
$body =~ s/\r//g;
|
||||
my $res = $self->{tar}->add_data( name => $filename, body => $body );
|
||||
}
|
||||
my @to_delete = $cgi->param('delete_files');
|
||||
foreach my $file (@to_delete) {
|
||||
$self->{tar}->remove_file($file);
|
||||
}
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Private Methods #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub _load_plugin {
|
||||
# ----------------------------------------------------------------
|
||||
# Examines a plugin tar and fills up self with info.
|
||||
#
|
||||
my $self = shift;
|
||||
my $author = $self->{tar}->get_file('Author.pm') or return $self->error('CANTLOAD', 'WARN', $self->{plugin_name}, "No Author.pm file found in tar!");
|
||||
|
||||
# Eval the install file.
|
||||
my $file = $author->body_as_string;
|
||||
{
|
||||
local ($@, $SIG{__DIE__}, $^W);
|
||||
eval "$file";
|
||||
if ($@) {
|
||||
return $self->error('CANTLOAD', 'WARN', $file, "Author.pm does not compile: $@");
|
||||
}
|
||||
}
|
||||
|
||||
# Load the information.
|
||||
no strict 'refs';
|
||||
my $var = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::AUTHOR";
|
||||
my $author_info = ${$var};
|
||||
if (ref $author_info eq 'HASH') {
|
||||
foreach my $key (keys %$author_info) {
|
||||
$self->{$key} = $author_info->{$key};
|
||||
}
|
||||
}
|
||||
use strict 'refs';
|
||||
$self->_load_install;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _load_tar {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads the tar file into memory.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $PLUGIN_DIR . "/Author/" . $self->{plugin_name} . ".tar";
|
||||
if (-e $file) {
|
||||
$self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
||||
}
|
||||
else {
|
||||
$self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
||||
}
|
||||
}
|
||||
|
||||
sub _create_author {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the author.pm file used by the web tool to auto create the plugin.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = '';
|
||||
my $time = localtime();
|
||||
my $version = $self->{version} || 0;
|
||||
my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta});
|
||||
|
||||
$output = <<END_OF_PLUGIN;
|
||||
# ==================================================================
|
||||
# Auto Generated Plugin Configuration - Needed for Web Based Creator.
|
||||
#
|
||||
# $self->{prefix}Plugins::$self->{plugin_name}
|
||||
# Author : $self->{meta}->{author}
|
||||
# Version : $self->{version}
|
||||
# Updated : $time
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package $self->{prefix}Plugins::$self->{plugin_name};
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/\$AUTHOR/;
|
||||
|
||||
END_OF_PLUGIN
|
||||
my $author = {};
|
||||
foreach (keys %$ATTRIBS) {
|
||||
next if ($_ eq 'tar');
|
||||
$author->{$_} = $self->{$_};
|
||||
}
|
||||
$output .= GT::Dumper->dump(var => '$AUTHOR', data => $author);
|
||||
$output .= "\n\n1;\n";
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub _escape_html {
|
||||
# -------------------------------------------------------------------
|
||||
# Escape html.
|
||||
#
|
||||
my $val = shift;
|
||||
defined $val or return '';
|
||||
$val =~ s/&/&/g;
|
||||
$val =~ s/</</g;
|
||||
$val =~ s/>/>/g;
|
||||
$val =~ s/"/"/g;
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _create_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated install function. Must return status message to user.
|
||||
#
|
||||
my \$mgr = new GT::Plugins::Manager;~;
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
$code .= qq~
|
||||
\$mgr->install_hooks('$self->{plugin_name}', [['$hook->[0]', '$hook->[1]', '$hook->[2]']]);~;
|
||||
}
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
$code .= qq~
|
||||
\$mgr->install_menu('$self->{plugin_name}', [['$menu->[0]', '$menu->[1]']]);~;
|
||||
}
|
||||
if (keys %{$self->{options}}) {
|
||||
my $options = GT::Dumper->dump(var => '$opts', data => $self->{options});
|
||||
$options =~ s/\n/\n\t/g;
|
||||
$code .= qq~
|
||||
my $options
|
||||
\$mgr->install_options('$self->{plugin_name}', \$opts);~;
|
||||
}
|
||||
$code .= qq~
|
||||
return "Plugin $self->{plugin_name} installed successfully.";
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated uninstall function. Must return status message to user.
|
||||
#
|
||||
my \$message = "Plugin $self->{plugin_name} has been uninstalled.";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_preinstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub pre_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated pre_install function. Must return status message to user.
|
||||
#
|
||||
my \$message = "INSERT INSTALL MESSAGE HERE";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_preuninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub pre_uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated pre_uninstall function. Must return status message to user.
|
||||
#
|
||||
my \$message = "INSERT UNINSTALL MESSAGE HERE";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _load_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Load the install functions from the Install.pm file.
|
||||
#
|
||||
my $self = shift;
|
||||
return unless ($self->{tar});
|
||||
my $install = $self->{tar}->get_file('Install.pm') or return;
|
||||
my $install_code = $install->body_as_string;
|
||||
$self->{pre_install} = $self->_parse_sub('pre_install', \$install_code);
|
||||
$self->{install} = $self->_parse_sub('install', \$install_code);
|
||||
$self->{pre_uninstall} = $self->_parse_sub('pre_uninstall', \$install_code);
|
||||
$self->{uninstall} = $self->_parse_sub('uninstall', \$install_code);
|
||||
}
|
||||
|
||||
sub _replace_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Load the install functions from the Install.pm file.
|
||||
#
|
||||
my ($self, $install) = @_;
|
||||
return unless ($install);
|
||||
|
||||
my $install_code = $install->body_as_string;
|
||||
$install_code =~ s/\r//g;
|
||||
$self->_replace_sub('pre_install', \$install_code, $self->{pre_install});
|
||||
$self->_replace_sub('install', \$install_code, $self->{install});
|
||||
$self->_replace_sub('pre_uninstall', \$install_code, $self->{pre_uninstall});
|
||||
$self->_replace_sub('uninstall', \$install_code, $self->{uninstall});
|
||||
$install_code =~ s/(\$VERSION\s*=\s*)(['"]?)[\d\.]+(['"]?)/$1$2$self->{version}$3/;
|
||||
$install_code =~ s/(Version\s*:\s*)[\d\.]+/$1$self->{version}/;
|
||||
$install_code =~ s/\$META\s*=\s*[^\}]+\}[\s\n]*;[\s\n]*/GT::Dumper->dump(var => '$META', data => $self->{meta}) . "\n"/esm;
|
||||
$install->body($install_code);
|
||||
}
|
||||
|
||||
sub _parse_sub {
|
||||
# -------------------------------------------------------------------
|
||||
# Parse out a subroutine in some code, and return it.
|
||||
#
|
||||
my ($self, $sub, $code) = @_;
|
||||
return '' unless ($sub and $$code);
|
||||
|
||||
$$code =~ m/(\s*)(sub\s+$sub[^\{]*\{.*?\n\1\})/sm;
|
||||
my $code_block = $2 || '';
|
||||
$code_block =~ s/\r//g;
|
||||
return $code_block;
|
||||
}
|
||||
|
||||
sub _replace_sub {
|
||||
# -------------------------------------------------------------------
|
||||
# Parse out a subroutine in some code, and replace it.
|
||||
#
|
||||
my ($self, $sub, $code, $new) = @_;
|
||||
return unless ($new);
|
||||
$new =~ s/\r//g;
|
||||
$new =~ s/^[\s\n]+|[\s\n]$//g;
|
||||
$$code =~ s/\r//g;
|
||||
if (! ($$code =~ s/([\s\n]*)(sub\s+$sub[^\{]*\{.*?\n\1\})/\n$new/sm)) {
|
||||
$$code =~ s/1;[\s\n\r]+$//gsm;
|
||||
$$code .= "\n" . $new . "\n1;\n\n";
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
258
site/glist/lib/GT/Plugins/Installer.pm
Normal file
258
site/glist/lib/GT/Plugins/Installer.pm
Normal file
@ -0,0 +1,258 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Installer.pm,v 1.13 2004/08/23 19:54:27 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A web based admin to install/uninstall plugins.
|
||||
#
|
||||
|
||||
package GT::Plugins::Installer;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
|
||||
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/;
|
||||
use GT::Base;
|
||||
use GT::Plugins;
|
||||
use GT::Tar;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Plugins';
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
plugin_dir => undef,
|
||||
prog_ver => undef,
|
||||
prog_user_cgi => undef,
|
||||
prog_admin_cgi => undef,
|
||||
prog_images => undef,
|
||||
prog_libs => undef
|
||||
};
|
||||
@ISA = qw/GT::Base/;
|
||||
|
||||
sub init {
|
||||
# ----------------------------------------------------------------
|
||||
# Load the plugin config file on init() called from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
my $param = $self->common_param(@_);
|
||||
$self->set($param);
|
||||
if (! $self->{plugin_dir} or ! -d $self->{plugin_dir}) {
|
||||
return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager.");
|
||||
}
|
||||
$self->{cfg} = GT::Plugins->load_cfg($self->{plugin_dir});
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
# Utilities used in Install/Uninstall by Plugins #
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
|
||||
sub install_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of plugin hooks.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
if (ref $hooks ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['hookname', 'PRE/POST', 'action'], ...])");
|
||||
}
|
||||
if (ref $hooks->[0] ne 'ARRAY') {
|
||||
$hooks = [ $hooks ];
|
||||
}
|
||||
foreach my $hook (@$hooks) {
|
||||
my ($hookname, $prepost, $action) = @$hook;
|
||||
if (! ((uc $prepost eq 'PRE') or (uc $prepost eq 'POST'))) {
|
||||
die "Invalid hook argument. Must be pre/post, not: $prepost";
|
||||
}
|
||||
push @{$self->{cfg}->{$plugin}->{hooks}}, [lc $hookname, uc $prepost, $action, 1];
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of menu options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
if (ref $menus ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['title', 'url'], ...])");
|
||||
}
|
||||
if (ref $menus->[0] ne 'ARRAY') {
|
||||
$menus = [ $menus ];
|
||||
}
|
||||
foreach my $menu (@$menus) {
|
||||
push @{$self->{cfg}->{$plugin}->{menu}}, $menu;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts, ) = @_;
|
||||
if (ref $opts ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', [['name', 'val', 'instructions'] ...])");
|
||||
}
|
||||
if (ref $opts->[0] ne 'ARRAY') {
|
||||
$opts = [ $opts ];
|
||||
}
|
||||
foreach my $opt (@$opts) {
|
||||
exists $self->{cfg}->{$plugin}->{user} or ($self->{cfg}->{$plugin}->{user} = []);
|
||||
push @{$self->{cfg}->{$plugin}->{user}}, $opt;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a registry item for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
if (ref $opts ne 'HASH') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', { key => value, ... })");
|
||||
}
|
||||
my $registry = ($self->{cfg}->{$plugin}->{registry} ||= {});
|
||||
foreach my $key (keys %$registry) {
|
||||
$registry->{$key} = $registry->{$key};
|
||||
}
|
||||
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub uninstall_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove plugins, just a no-op as the config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove menus, no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove options, just a no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove registry, just a no-op as config gets deleted.
|
||||
#
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Plugins::Installer
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$mgr->install_hooks('PluginName', ['hook_name', 'PRE|POST', 'code']);
|
||||
$mgr->install_menu('PluginName', ['menu_name', 'menu_url', 'enabled']);
|
||||
$mgr->install_options('PluginName', ['option_key', 'option_val', 'instructions']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The installer is an object that is passed into plugins during installation.
|
||||
It provides methods to add hooks, menu options, admin options or copy files
|
||||
into the users application.
|
||||
|
||||
=head2 install_hooks
|
||||
|
||||
C<install_hooks> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item hook_name
|
||||
|
||||
The hook you want to override.
|
||||
|
||||
=item PRE/POST
|
||||
|
||||
Either the string PRE or POST depending on whether the hook should be run
|
||||
before the main code, or after.
|
||||
|
||||
=item code
|
||||
|
||||
The name of the code to run. It should be Plugins::PACKAGE::YourPluginName::function.
|
||||
Where PACKAGE is the name of the Gossamer Product the plugin is for. For example
|
||||
Plugins::GMail::Wap::header
|
||||
|
||||
=back
|
||||
|
||||
C<install_hooks> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_menu
|
||||
|
||||
C<install_menu> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item menu_name
|
||||
|
||||
The name that will show up in the admin menu.
|
||||
|
||||
=item menu_url
|
||||
|
||||
The URL for the menu option.
|
||||
|
||||
=item enabled
|
||||
|
||||
Either true or false depending on whether the menu option should be shown.
|
||||
|
||||
=back
|
||||
|
||||
C<install_menu> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_options
|
||||
|
||||
C<install_options> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item option_key
|
||||
|
||||
This is the key, and is used when accessing the options hash.
|
||||
|
||||
=item option_value
|
||||
|
||||
This is the default value.
|
||||
|
||||
=item instructions
|
||||
|
||||
A string instruction users on what the plugin does.
|
||||
|
||||
=back
|
||||
|
||||
C<install_options> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Installer.pm,v 1.13 2004/08/23 19:54:27 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1170
site/glist/lib/GT/Plugins/Manager.pm
Normal file
1170
site/glist/lib/GT/Plugins/Manager.pm
Normal file
File diff suppressed because it is too large
Load Diff
1098
site/glist/lib/GT/Plugins/Wizard.pm
Normal file
1098
site/glist/lib/GT/Plugins/Wizard.pm
Normal file
File diff suppressed because it is too large
Load Diff
155
site/glist/lib/GT/RDF.pm
Normal file
155
site/glist/lib/GT/RDF.pm
Normal file
@ -0,0 +1,155 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::RDF
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: RDF.pm,v 1.2 2001/04/11 02:37:12 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: An RDF parser.
|
||||
#
|
||||
|
||||
package GT::RDF;
|
||||
|
||||
use GT::Base;
|
||||
use strict;
|
||||
use vars qw/$DEBUG @ISA $TAG $ERRORS/;
|
||||
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$TAG = 'Topic|ExternalPage';
|
||||
$ERRORS = {};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1) {
|
||||
$self->io (shift()) or return;
|
||||
}
|
||||
else {
|
||||
if (ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined ($_[0]) and not @_ % 2) { $opt = {@_} }
|
||||
exists ($opt->{io}) or return $self->error ("BADARGS", "FATAL", 'CLASS->new (%opt) %opt must contain the key io and it must be either a file handle or a path to a file.');
|
||||
$self->io ($opt->{io});
|
||||
}
|
||||
$self->{io} || return $self->error ("BADARGS", "FATAL", 'CLASS->new (\\*FH) -or- CLASS->new (%opts). You must define in input. Either a file or a file handle');
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub io {
|
||||
my ($self, $io) = @_;
|
||||
if (ref $io eq 'GLOB') {
|
||||
$self->{io} = $io;
|
||||
}
|
||||
elsif (-e $io) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, $io or return $self->error ("OPENREAD", "FATAL", $!);
|
||||
$self->{io} = $fh;
|
||||
}
|
||||
else {
|
||||
return $self->error ("BADARGS", "FATAL", '$obj->io (\*FH) -or- $obj->io ("/path/to/file")');
|
||||
}
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
my $io = $self->{io};
|
||||
|
||||
while (1) {
|
||||
$self->{name} = '';
|
||||
$self->{attribs} = {};
|
||||
$self->{tags} = [];
|
||||
my $parse;
|
||||
if ($self->{buffer} =~ s,(<($TAG).*?</\2[^>]*?>),$parse = $1; '',oes) {
|
||||
my @tokens = grep !/^\s*$/, split /(<[^>]+?>)/, $parse;
|
||||
my $start = shift (@tokens);
|
||||
|
||||
# Discard closing tag
|
||||
pop (@tokens);
|
||||
|
||||
# Get the start tag and its attributes
|
||||
$start =~ /^<($TAG)\s*(.*[^\/])>$/os;
|
||||
$self->{name} = $1;
|
||||
my $attr = $2;
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $ret = {};
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
$self->{attribs} = $ret;
|
||||
}
|
||||
|
||||
# Parse the remaining tags.
|
||||
my $last_entry;
|
||||
for (@tokens) {
|
||||
if (/^<([^\/\s]+)\s*(.*?[^\/])?>$/s) {
|
||||
my $tag = $1;
|
||||
my $attr = $2;
|
||||
my $ret = {};
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
$last_entry = { name => $tag, attribs => $ret };
|
||||
push (@{$self->{tags}}, $last_entry);
|
||||
}
|
||||
elsif (/^<([^\s\/]+)\s*(.*?)\/>$/s) {
|
||||
my $tag = $1;
|
||||
my $attr = $2;
|
||||
my $ret = {};
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
my $entry = { name => $tag, attribs => $ret };
|
||||
push (@{$self->{tags}}, $entry);
|
||||
}
|
||||
elsif (/^([^<]+)$/ and $last_entry) {
|
||||
$last_entry->{data} = $1;
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
# No match
|
||||
else {
|
||||
my $tmp;
|
||||
read ($io, $tmp, 3072) or last;
|
||||
$self->{buffer} .= $tmp;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
715
site/glist/lib/GT/SQL.pm
Normal file
715
site/glist/lib/GT/SQL.pm
Normal file
@ -0,0 +1,715 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL
|
||||
# CVS Info :
|
||||
# $Id: SQL.pm,v 1.111 2005/04/14 20:22:37 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to a RDBMS.
|
||||
#
|
||||
|
||||
package GT::SQL;
|
||||
# ==================================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use GT::Config;
|
||||
use GT::SQL::Base;
|
||||
use GT::SQL::Table;
|
||||
use GT::SQL::Driver;
|
||||
use strict;
|
||||
use vars qw(@ISA $DEBUG $ERRORS $VERSION %OBJ_CACHE $error $errcode);
|
||||
|
||||
@ISA = qw(GT::SQL::Base);
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.111 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERRORS = {
|
||||
# Common Errors
|
||||
UNIQUE => "The column '%s' must be unique, and already has an entry '%s'",
|
||||
NOTABLE => 'No table defined -- call $db->table($table) before accessing',
|
||||
CANTOPEN => "Cannot open file '%s': %s",
|
||||
CANTOPENDIR => "Cannot read directory '%s': %s",
|
||||
FILENOEXISTS => "File '%s' does not exist or the permissions are set incorrectly",
|
||||
# GT::SQL Errors
|
||||
NODRIVER => "Database driver %s is not installed. Available drivers: %s",
|
||||
CANTLOAD => "Unable to load driver '%s': %s",
|
||||
BADPREFIX => "Invalid prefix: '%s'",
|
||||
NODATABASE => 'No database def file -- create def file with ->set_connect before calling $obj->%s',
|
||||
CANTCONNECT => "Could not connect to database: %s",
|
||||
CANTPREPARE => "Failed to prepare query: '%s': %s",
|
||||
CANTEXECUTE => "Failed to execute query: '%s': %s",
|
||||
BADSUBCLASS => "Unable to load subclass: '%s': %s",
|
||||
NEEDDEBUG => "You must turn on debug in order to access query logs",
|
||||
NOORACLEHOME => "The environment variable ORACLE_HOME is not defined. It must be defined for the script to connect properly",
|
||||
NONLSDATE => "Unable to set NLS_DATE_FORMAT: %s",
|
||||
# Table Errors
|
||||
BADNAME => "Invalid table name '%s'",
|
||||
NOTNULL => "Column %s cannot be left blank",
|
||||
NORECMOD => "The record you are attempting to modify no longer exists in the current table",
|
||||
NOVALUES => "You did not pass any valid column names to %s",
|
||||
BADMULTVALUES => "One or more of the value groups passed to %s contained an incorrect number of values",
|
||||
NOPKTOMOD => "Cannot modify record, no primary key specified",
|
||||
DEPENDENCY => "Table %s has dependencies. Aborting",
|
||||
ILLEGALVAL => "%s cannot contain the value '%s'",
|
||||
ALREADYCHANGED => "The record you are attempting to modify has changed since you last accessed it",
|
||||
REGEXFAIL => "The regular expressions %s for this column is not properly formed",
|
||||
FKNOTABLE => "A foreign key is referencing a non existant table: %s. GT::SQL load error: %s",
|
||||
FKNOEXISTS => "You attempted to remove non-existent foreign key '%s' from table '%s'",
|
||||
CIRCULAR => "Circular reference detected in the foreign key schema. Already seen column: %s",
|
||||
CIRCULARLIMIT => "Loop detected in circular reference check, hit maximum recursion depth of 100",
|
||||
# Relation Errors
|
||||
BADCOLS => "Bad columns / column clash: columns named '%s' have been found in current relation, please qualify your expression",
|
||||
# Creator Errors
|
||||
BADTYPE => "%s is not a supported type",
|
||||
AINOTPK => "Column %s defined as auto_increment but is not an INT",
|
||||
TBLEXISTS => "Could not create table '%s': It already exists",
|
||||
NOTABLEDEFS => "You must define your table before creating it",
|
||||
NOPOS => "No position column was found in definition for column: %s",
|
||||
# Editor Errors
|
||||
NOCOL => "There is no column %s in this table",
|
||||
REFCOL => "You cannot alter column %s, as table %s still has references to it. Remove those references first",
|
||||
NOPK => "There is no primary key for this table",
|
||||
COLREF => "You cannot alter column %s, as it is a foreign key. Remove the foreign key first",
|
||||
NOINDEX => "You are trying to modify an index that does not exist",
|
||||
NOUNIQUE => "You are trying to drop a unique column '%s', but it is not unique",
|
||||
INDXQTEXT => "Cannot create index on '%s' as it is a text/blob field",
|
||||
COLEXISTS => "Unable to add column '%s' - already exists",
|
||||
NOTUNIQUE => "Cannot create unique index on '%s', data is not unique",
|
||||
INDXEXISTS => "Unable to add index '%s' - already exists",
|
||||
PKTEXT => "Column %s specified as a primary key but is a text or a blob type",
|
||||
UNIQTEXT => "Column %s specified as a unique but is a text or blob column type",
|
||||
TABLEREFD => "%s cannot be dropped as table still has references to it",
|
||||
NOFILESAVEIN => "Column %s must have file_save_in set if is to be File type",
|
||||
NODIRPRIV => "Privileges on directory %s do not allow write or directory does not exist",
|
||||
SAMEDRIVER => "Search Driver '%s' is unchanged",
|
||||
NOTNULLDEFAULT => "Column %s was specified as not null, but has no default value",
|
||||
# Admin Error
|
||||
NOACTION => "The CGI object passed in did not contain a valid action. %s",
|
||||
# Tree errors
|
||||
NOTREE => "No tree object exists for table '%s'. Create a tree first with \$editor->add_tree",
|
||||
NOTREEOBJ => "You attempted to call '%s' without a valid tree object. Call \$table->tree() first",
|
||||
TREEEXISTS => "A tree already exists for table '%s'",
|
||||
TREENOCANDO => "You attempted to call '%s' on table '%s', but that table has a tree attached and does not support the command",
|
||||
TREENOIDS => "You did not pass any ID's to %s",
|
||||
TREEBADPK => "You tried to create a tree on table '%s', but that table doesn't have a primary key, or has multiple primary keys",
|
||||
TREEBADJOIN => "Joining more than 2 tables with a tree is not supported. You attempted to join: %s",
|
||||
TREEFATHER => "Unable to update a tree record to a descendant of itself",
|
||||
# Driver errors
|
||||
DRIVERPROTOCOL => "Driver implements wrong protocol: protocol v%d required, driver is v%d",
|
||||
};
|
||||
|
||||
use constant DEF_HEADER => <<'HEADER';
|
||||
# Database access & configuration file
|
||||
# Last updated: [localtime]
|
||||
# Created by GT::SQL $Revision: 1.111 $
|
||||
HEADER
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------------------
|
||||
# GT::SQL constructor. Takes:
|
||||
# my $db = new GT::SQL '/path/to/def';
|
||||
# my $db = new GT::SQL { def_path => '/defpath', debug => 1 };
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless { _err_pkg => __PACKAGE__, _debug => $DEBUG }, $class;
|
||||
|
||||
# Get our arguments into a hash ref
|
||||
my $opts = {};
|
||||
if (@_ == 0) { $opts = {}; }
|
||||
elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift; }
|
||||
elsif (@_ > 1 and !(@_ % 2)) { $opts = {@_}; }
|
||||
else {
|
||||
$opts->{def_path} = shift;
|
||||
}
|
||||
|
||||
# Set debugging level, caching options and whether to allow subclassing.
|
||||
$self->{_debug} = exists $opts->{debug} ? $opts->{debug} : $DEBUG;
|
||||
$self->{cache} = exists $opts->{cache} ? $opts->{cache} : 1;
|
||||
$self->{subclass} = exists $opts->{subclass} ? $opts->{subclass} : 1;
|
||||
|
||||
# Def path must exist and be a directory
|
||||
exists $opts->{def_path} or return $self->fatal(BADARGS => "$class->new(HASH_REF). def_path must be defined and a directory path in the hash");
|
||||
-d $opts->{def_path} or return $self->fatal(BADARGS => "The defs directory '$opts->{def_path}' does not exist, or is not a directory");
|
||||
|
||||
# Load the database def file if it exists
|
||||
|
||||
# Some old programs would sometimes erroneously leave an invalid blank
|
||||
# database.def file in the def_path; if such a file exists, make GT::Config
|
||||
# ignore it.
|
||||
my $empty = (-f "$opts->{def_path}/database.def" and !-s _);
|
||||
|
||||
$self->{connect} = GT::Config->load(
|
||||
"$opts->{def_path}/database.def" => {
|
||||
create_ok => 1,
|
||||
chmod => 0666,
|
||||
debug => $self->{_debug},
|
||||
header => DEF_HEADER,
|
||||
($empty ? (empty => 1) : ()),
|
||||
}
|
||||
);
|
||||
|
||||
$self->{connect}->{PREFIX} = '' unless defined $self->{connect}->{PREFIX};
|
||||
# Heavily deprecated. Not guaranteed to always be correct:
|
||||
$GT::SQL::PREFIX = $self->{connect}->{PREFIX};
|
||||
$self->{connect}->{def_path} = $opts->{def_path};
|
||||
$self->{connect}->{obj_cache} = $self->{cache};
|
||||
|
||||
$self->debug("OBJECT CREATED") if $self->{_debug} and $self->{_debug} > 2;
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{set_connect} = __LINE__ . <<'END_OF_SUB';
|
||||
sub set_connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Sets the connection info, only needed to setup the database.def file.
|
||||
# $db->set_connect({
|
||||
# driver => 'mysql',
|
||||
# host => 'localhost',
|
||||
# port => 2323,
|
||||
# database => 'mydatabase',
|
||||
# login => 'user',
|
||||
# password => 'foo',
|
||||
# }) or die "Can't connect: $GT::SQL::error";
|
||||
#
|
||||
my $self = shift;
|
||||
my $connect = $self->{connect};
|
||||
my %old_connect = %$connect;
|
||||
# Parse our arguments.
|
||||
if (!@_) { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }
|
||||
elsif (@_ == 1 and ref $_[0] eq 'HASH') { %$connect = %{+shift} }
|
||||
elsif (@_ % 2 == 0) { %$connect = @_ }
|
||||
else { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }
|
||||
|
||||
if (keys %old_connect) {
|
||||
for (keys %old_connect) {
|
||||
$connect->{$_} = $old_connect{$_} unless exists $connect->{$_};
|
||||
}
|
||||
}
|
||||
$connect->{PREFIX} = '' unless defined $connect->{PREFIX};
|
||||
|
||||
# Fix the connect string for test connecting
|
||||
$connect->{driver} ||= 'mysql';
|
||||
|
||||
# Make sure DBI has been loaded
|
||||
eval { require DBI };
|
||||
$@ and return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
|
||||
|
||||
# Make sure the requested driver exists
|
||||
my @drivers = GT::SQL::Driver->available_drivers;
|
||||
unless (grep $_ eq uc $connect->{driver}, @drivers, 'ODBC') {
|
||||
return $self->warn(NODRIVER => $connect->{driver}, join ", ", @drivers);
|
||||
}
|
||||
|
||||
my $raiseerror = delete $connect->{RaiseError};
|
||||
my $printerror = delete $connect->{PrintError};
|
||||
$connect->{RaiseError} = 0;
|
||||
$connect->{PrintError} = 0;
|
||||
|
||||
# Get our driver.
|
||||
my $table = GT::SQL::Table->new(connect => $connect, debug => $self->{_debug});
|
||||
$table->connect or return;
|
||||
|
||||
# Put things back the way they were.
|
||||
$connect->{RaiseError} = defined $raiseerror ? $raiseerror : 1;
|
||||
$connect->{PrintError} = defined $printerror ? $printerror : 0;
|
||||
|
||||
$self->{connect} = $connect;
|
||||
|
||||
# Use this connect string from now on.
|
||||
$self->write_db_config;
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{write_db_config} = __LINE__ . <<'END_OF_SUB';
|
||||
sub write_db_config {
|
||||
# -------------------------------------------------------------------
|
||||
# Saves the database.def file. Takes no arguments.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{connect}->save;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# ============================================================================ #
|
||||
# DATABASE INFO ACCESSORS #
|
||||
# ============================================================================ #
|
||||
$COMPILE{driver} = __LINE__ . <<'END_OF_SUB';
|
||||
sub driver {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the driver being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{driver};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{host} = __LINE__ . <<'END_OF_SUB';
|
||||
sub host {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the host being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{host};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{port} = __LINE__ . <<'END_OF_SUB';
|
||||
sub port {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the port currently being used, undef if default.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{port};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{database} = __LINE__ . <<'END_OF_SUB';
|
||||
sub database {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the database being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{database};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{login} = __LINE__ . <<'END_OF_SUB';
|
||||
sub login {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the login username for the current connection.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{login};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{password} = __LINE__ . <<'END_OF_SUB';
|
||||
sub password {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the login password for the current connection.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{password};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# ============================================================================ #
|
||||
# HTML ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
$COMPILE{html} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html {
|
||||
# -------------------------------------------------------------------
|
||||
# Return an html object. Takes an array ref of table names, or a, and a cgi
|
||||
# object.
|
||||
# my $html = $db->html(['Links'], $in);
|
||||
# or
|
||||
# my $html = $db->html($table_obj, $in);
|
||||
#
|
||||
my ($self, $tables, $cgi) = @_;
|
||||
ref $tables or return $self->fatal(BADARGS => 'Error: no table array ref passed to html');
|
||||
ref $cgi or return $self->fatal(BADARGS => 'Error: no cgi object/hash ref passed to html');
|
||||
|
||||
# If already passed a table object, use it, otherwise create a new one
|
||||
my ($table);
|
||||
if (ref $tables eq 'ARRAY') {
|
||||
$table = $self->table(@$tables);
|
||||
}
|
||||
elsif (UNIVERSAL::isa($tables, 'GT::SQL::Table') or UNIVERSAL::isa($tables, 'GT::SQL::Relation')) {
|
||||
$table = $tables;
|
||||
}
|
||||
else {
|
||||
return $self->fatal(BADARGS => "Error: '$tables' must be either an array ref or a table object");
|
||||
}
|
||||
|
||||
my $meth = @{[$table->name]} > 1 ? "_html_relation" : "_html_table";
|
||||
$self->$meth($table, $cgi);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_html_relation} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _html_relation {
|
||||
my ($self, $rel, $cgi) = @_;
|
||||
|
||||
my $class;
|
||||
my $key = join "\0", map { s/^$self->{connect}->{PREFIX}//; $_ } sort keys %{$rel->{tables}};
|
||||
foreach my $table (values %{$rel->{tables}}) {
|
||||
my $subclass = $table->subclass;
|
||||
if ($self->{subclass} and exists $subclass->{html}->{$self->{connect}->{PREFIX} . $key}) {
|
||||
$class = $subclass->{html}->{$self->{connect}->{PREFIX} . $key};
|
||||
$self->_load_module($class) or return;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if (!$class) {
|
||||
require GT::SQL::Display::HTML::Relation;
|
||||
$class = 'GT::SQL::Display::HTML::Relation';
|
||||
}
|
||||
return $class->new(
|
||||
db => $rel,
|
||||
input => $cgi
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_html_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _html_table {
|
||||
my ($self, $table, $cgi) = @_;
|
||||
my $class;
|
||||
if ($self->{subclass} and $table->{schema}->{subclass}->{html}->{$table->name}) {
|
||||
$class = $table->{schema}->{subclass}->{html}->{$table->name};
|
||||
$self->_load_module($class) or return;
|
||||
}
|
||||
if (!$class) {
|
||||
require GT::SQL::Display::HTML::Table;
|
||||
$class = 'GT::SQL::Display::HTML::Table';
|
||||
}
|
||||
return $class->new(
|
||||
db => $table,
|
||||
input => $cgi
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub query_stack {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns raw query stack (as array/array ref).
|
||||
#
|
||||
return wantarray ? @GT::SQL::Driver::debug::QUERY_STACK : \@GT::SQL::Driver::debug::QUERY_STACK;
|
||||
}
|
||||
|
||||
sub query_stack_disp {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns formatted query stack (handled in Driver.pm).
|
||||
#
|
||||
my ($out, $i) = ('', 0);
|
||||
foreach (reverse 0 .. $#GT::SQL::Driver::debug::QUERY_STACK) {
|
||||
my $query = $GT::SQL::Driver::debug::QUERY_STACK[$_];
|
||||
my $stack = $GT::SQL::Driver::debug::STACK_TRACE[$_] || '';
|
||||
$i++;
|
||||
chomp $query;
|
||||
$query =~ s/^[\s]*(.*?)[\s]*$/$1/mg;
|
||||
$query =~ s/\n/\n /mg;
|
||||
$out .= "$i: $query\n$stack";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prefix {
|
||||
# -------------------------------------------------------------------
|
||||
# Set/Get the database prefix to be attached to all tables. Calling this as a
|
||||
# class accessor method is extremely deprecated (it returns $GT::SQL::PREFIX,
|
||||
# which is itself extremely deprecated); calling this to *set* a prefix is not
|
||||
# permitted.
|
||||
#
|
||||
|
||||
my $self = shift;
|
||||
|
||||
if (@_) {
|
||||
ref $self or $self->fatal(BADARGS => 'Usage: $obj->prefix(...) not CLASS->prefix(...)');
|
||||
my $prefix = shift;
|
||||
if ($prefix =~ /\W/) {
|
||||
return $self->fatal(BADPREFIX => $prefix);
|
||||
}
|
||||
$self->{connect}->{PREFIX} = $prefix;
|
||||
}
|
||||
else {
|
||||
return ref $self ? $self->{connect}->{PREFIX} : $GT::SQL::PREFIX;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{reset_env} = __LINE__ . <<'END_OF_SUB';
|
||||
sub reset_env {
|
||||
# -------------------------------------------------------------------
|
||||
# Reset globals.
|
||||
#
|
||||
GT::SQL::Driver->reset_env(); # Shut down database connections.
|
||||
%OBJ_CACHE = ();
|
||||
$error = '';
|
||||
$errcode = '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL - A database independent perl interface
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::SQL;
|
||||
|
||||
my $db = GT::SQL->new('/path/to/def');
|
||||
my $table = $db->table('Links');
|
||||
my $editor = $db->editor('Links');
|
||||
my $creator = $db->creator('NewTable');
|
||||
my $html = $db->html('Links', new CGI);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::SQL is a perl database abstraction layer to relational databases, providing
|
||||
a native Perl interface rather than a query-based interface.
|
||||
|
||||
A GT::SQL object provides the interface to the entire database by providing
|
||||
objects that are able to perform the work needed.
|
||||
|
||||
=head2 Creating a new GT::SQL object
|
||||
|
||||
There are two ways to get a GT::SQL object. First, you can simply provide the
|
||||
path to the def file directory where GT::SQL stores all it's information:
|
||||
|
||||
$db = GT::SQL->new('/path/to/def');
|
||||
|
||||
or you can pass in a hash or hash ref and specify options:
|
||||
|
||||
$db = GT::SQL->new(
|
||||
def_path => '/path/to/def',
|
||||
cache => 1,
|
||||
debug => 1,
|
||||
subclass => 1
|
||||
);
|
||||
|
||||
You must specify def_path. Setting C<cache =E<gt> 1> will result in all table
|
||||
and relation objects being cached, which provides a performance improvement in
|
||||
any situation where the same table or relation is used again.
|
||||
|
||||
Specifying C<subclass =E<gt> 0> or C<subclass =E<gt> 1> will enable or disable
|
||||
the ability to subclass any of the objects GT::SQL creates. The default
|
||||
value is C<1>, and should not normally be changed.
|
||||
|
||||
GT::SQL has significant amounts of debugging output that can be enabled by
|
||||
specifying a value of C<1> to the C<debug> option. Larger values can be
|
||||
specified for more detailed debugging output, however a level of C<1> is almost
|
||||
always more than sufficient. The accepted values are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Level 0
|
||||
|
||||
This is the default, no debugging information is printed to stderr. All errors
|
||||
can be obtained in $GT::SQL::error.
|
||||
|
||||
=item Level 1
|
||||
|
||||
All queries will be displayed to stderr. This is the recommended value if
|
||||
query debugging is desired.
|
||||
|
||||
=item Level 2
|
||||
|
||||
Same as level 1, but includes more detailed information. Also, when calling
|
||||
query_stack you get a stack trace on what generated each query. Not
|
||||
recommended except when working directly on GT::SQL.
|
||||
|
||||
=item Level 3
|
||||
|
||||
Very detailed debug logs including creation and destruction of objects.
|
||||
query_stack generates a javascript page with query, stack trace, and data dump
|
||||
of arguments, but can be extremely large. Not recommended except for debugging
|
||||
GT::SQL internals.
|
||||
|
||||
=back
|
||||
|
||||
B<Pass in a def path>
|
||||
|
||||
$obj = GT::SQL->new('/path/to/def/directory');
|
||||
|
||||
This method of calling new is also supported, however has the drawback that
|
||||
none of the above options can be provided.
|
||||
|
||||
=head2 Getting Connected
|
||||
|
||||
GT::SQL loads the database connection info from database.def which is located
|
||||
in the defs directory.
|
||||
|
||||
To create this file, you call set_connect() as follows:
|
||||
|
||||
$obj->set_connect({
|
||||
driver => 'mysql',
|
||||
host => 'localhost',
|
||||
port => 3243,
|
||||
database => 'databasename',
|
||||
login => 'username',
|
||||
password => 'password',
|
||||
PREFIX => 'prefix_'
|
||||
});
|
||||
|
||||
This will test the database information, and save it to the def file. All
|
||||
future connections will automatically use this connection information.
|
||||
|
||||
Not all of the arguments in this hash are necessary; some have reasonable
|
||||
defaults for the connection.
|
||||
|
||||
=over 4
|
||||
|
||||
=item driver
|
||||
|
||||
This needs to be the driver that is being used for the connection. The default
|
||||
for this is C<mysql>. Driver names are case-insensitive. Available drivers
|
||||
are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item MySQL
|
||||
|
||||
Driver for MySQL databases. Requires that the DBD::mysql module be installed.
|
||||
|
||||
=item Pg
|
||||
|
||||
Driver for PostgreSQL databases. Requires that the DBD::Pg module be
|
||||
installed.
|
||||
|
||||
=item MSSQL
|
||||
|
||||
Driver for MSSQL 7.0 and above. Requires that the DBD::ODBC module be
|
||||
installed.
|
||||
|
||||
=item Oracle
|
||||
|
||||
Driver for Oracle 8 and above. Requires the DBD::Oracle module.
|
||||
|
||||
=back
|
||||
|
||||
=item host
|
||||
|
||||
This will specify the host to connect to. The default, which is acceptable for
|
||||
most installations, is C<localhost>.
|
||||
|
||||
=item port
|
||||
|
||||
This is the port on which to connect to the SQL server. The default for this
|
||||
is to allow the DBI driver to choose the default, which is almost always the
|
||||
appropriate choice.
|
||||
|
||||
=item database
|
||||
|
||||
This is the database name to use on the SQL server. This is required to
|
||||
connect. For MSSQL, this is the I<Data Source> name.
|
||||
|
||||
=item PREFIX
|
||||
|
||||
This specifies a prefix to use for table names. See the L</"Table Prefixes">
|
||||
section below for more information.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Supported Objects
|
||||
|
||||
The following objects can be obtained through a GT::SQL object:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Table/Relation
|
||||
|
||||
To get a table or relation object for working with SQL tables, you should call:
|
||||
|
||||
my $table = $db->table('table_name');
|
||||
|
||||
or for a table join:
|
||||
|
||||
my $relation = $db->table('table_name', 'other_table');
|
||||
|
||||
See L<GT::SQL::Table> for more information on how to use a table object.
|
||||
|
||||
=item Creator
|
||||
|
||||
To create new tables, you need to use a creator. You can get one by calling:
|
||||
|
||||
my $creator = $db->creator('new_table');
|
||||
|
||||
where C<new_table> is the name of the table you wish to create. See
|
||||
L<GT::SQL::Creator> for more information on how to use a creator object.
|
||||
|
||||
=item Editor
|
||||
|
||||
To edit existing tables (i.e. add/drop/change columns, add/drop indexes, etc.)
|
||||
you need an editor object:
|
||||
|
||||
my $editor = $db->editor('existing_table');
|
||||
|
||||
where C<existing_table> is the name of the table you wish the modify. See
|
||||
L<GT::SQL::Editor> for more information on how to use an editor object.
|
||||
|
||||
=item HTML
|
||||
|
||||
To get an html object for generating forms and html output, you need to pass in
|
||||
the table/relation object you want to work with, and a cgi object:
|
||||
|
||||
my $html = $db->html($table, $cgi);
|
||||
|
||||
The html object uses information found in CGI to set values, etc. See
|
||||
L<GT::SQL::Display::HTML> for more information on how to use a html object.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Table Prefixes
|
||||
|
||||
GT::SQL supports the concept of table prefixes. If you specify a prefix using
|
||||
the accessor, it is saved in the database.def file and will be used in all
|
||||
future calls to table(), editor() and creator().
|
||||
|
||||
To set a prefix:
|
||||
|
||||
$db->prefix("foo");
|
||||
|
||||
to get the current prefix:
|
||||
|
||||
my $prefix = $db->prefix;
|
||||
|
||||
What this will do is transparently prepend C<foo> to the beginning of every
|
||||
table name. This means anywhere you access the table C<bar>, the actual table
|
||||
stored on the SQL server will be C<foobar>. Note that the prefix should B<not>
|
||||
be included when getting table/creator/editor/etc. objects - the prefix is
|
||||
handled completely transparently to all public GT::SQL functionality.
|
||||
|
||||
=head2 Query Stack
|
||||
|
||||
To display a list of all raw SQL queries sent to the database you can use:
|
||||
|
||||
my @queries = $db->query_stack;
|
||||
|
||||
or to have them formatted try
|
||||
|
||||
print $db->query_stack_disp;
|
||||
|
||||
which will join them up, displayed nicely. This is also available as a class
|
||||
method:
|
||||
|
||||
print GT::SQL->query_stack_disp;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::SQL::Table>
|
||||
|
||||
L<GT::SQL::Editor>
|
||||
|
||||
L<GT::SQL::Creator>
|
||||
|
||||
L<GT::SQL::Types>
|
||||
|
||||
L<GT::SQL::Admin>
|
||||
|
||||
L<GT::SQL::Display::HTML>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: SQL.pm,v 1.111 2005/04/14 20:22:37 alex Exp $
|
||||
|
||||
=cut
|
||||
3042
site/glist/lib/GT/SQL/Admin.pm
Normal file
3042
site/glist/lib/GT/SQL/Admin.pm
Normal file
File diff suppressed because it is too large
Load Diff
609
site/glist/lib/GT/SQL/Base.pm
Normal file
609
site/glist/lib/GT/SQL/Base.pm
Normal file
@ -0,0 +1,609 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# CVS Info :
|
||||
# $Id: Base.pm,v 1.69 2004/09/22 02:43:29 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base class for GT::SQL::Table and GT::SQL::Relation
|
||||
#
|
||||
|
||||
package GT::SQL::Base;
|
||||
# ===============================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use strict;
|
||||
use vars qw($ERRORS $DEBUG @ISA $VERSION $ERROR_MESSAGE);
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.69 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
|
||||
# ============================================================================ #
|
||||
# TABLE ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
sub table {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a table or relation argument. Called with array of table names:
|
||||
# my $relation = $db->table('Links', 'CatLinks', 'Category');
|
||||
# my $table = $db->table('Links');
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
|
||||
# Make sure we have a driver, and a list of tables were specified.
|
||||
$self->{connect} or return $self->fatal(NODATABASE => 'table()');
|
||||
@tables or return $self->fatal(BADARGS => 'Usage: $obj->table(@TABLES)');
|
||||
|
||||
for (@tables) { # Tables aren't passed to table() prefixed, so prefix them all.
|
||||
$_ = $self->{connect}->{PREFIX} . $_;
|
||||
}
|
||||
my $cache_key = join("\0", @tables, $self->{connect}->{def_path});
|
||||
$cache_key = (@tables > 1 ? "RELATION\0" : "TABLE\0") . $cache_key;
|
||||
$self->{cache} and exists $GT::SQL::OBJ_CACHE{$cache_key} and return $GT::SQL::OBJ_CACHE{$cache_key};
|
||||
|
||||
my $obj;
|
||||
if (@tables > 1) {
|
||||
$obj = $self->new_relation(@tables);
|
||||
}
|
||||
else {
|
||||
my $name = $self->{connect}->{def_path} . '/' . $tables[0] . '.def';
|
||||
(-e $name) or return $self->fatal(FILENOEXISTS => $name);
|
||||
$obj = $self->new_table($tables[0]);
|
||||
}
|
||||
# We don't need to worry about caching here - new_relation or new_table will add it to the cache.
|
||||
return $obj;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# EDITOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
$COMPILE{editor} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns an editor object. Takes a table name as argument.
|
||||
# my $editor = $db->editor('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->editor(\'tablename\')');
|
||||
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'editor()');
|
||||
|
||||
my $table = $self->table($table_name);
|
||||
|
||||
# Set the error package to reflect the editor
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
|
||||
# Get an editor object
|
||||
require GT::SQL::Editor;
|
||||
$self->debug("CREATING GT::SQL::Editor OBJECT") if $self->{_debug} > 2;
|
||||
return GT::SQL::Editor->new(
|
||||
debug => $self->{_debug},
|
||||
table => $table,
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prefix {
|
||||
my $self = shift;
|
||||
return $self->{connect}->{PREFIX};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub new_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates a table object for a single table.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $cache_key = "TABLE\0$table\0$self->{connect}->{def_path}";
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning table object for $table from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
$self->debug("Creating new table object for $table") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
# Create a blank table object.
|
||||
my $table_obj = GT::SQL::Table->new(
|
||||
name => $table, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table'
|
||||
);
|
||||
|
||||
# Create a new object if we are subclassed.
|
||||
my $subclass = $table_obj->subclass;
|
||||
my $name = $table_obj->name;
|
||||
my $class = $subclass->{table}->{$name} || 'GT::SQL::Table';
|
||||
if ($subclass and $subclass->{table}->{$name}) {
|
||||
no strict 'refs';
|
||||
$self->_load_module($class) or return;
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : {};
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
use strict 'refs';
|
||||
$table_obj = $class->new(
|
||||
name => $name, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table',
|
||||
_schema => $table_obj->{schema}
|
||||
);
|
||||
}
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $table_obj if $self->{connect}->{obj_cache};
|
||||
return $table_obj;
|
||||
}
|
||||
|
||||
sub new_relation {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the table objects and relation object for multi-table tasks.
|
||||
# Internal use. Call table instead.
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
my $href = {};
|
||||
my $tables_ord = [];
|
||||
my $tables = {};
|
||||
|
||||
require GT::SQL::Relation;
|
||||
|
||||
my $cache_key = join "\0", "RELATION", @tables, $self->{connect}->{def_path};
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning relation object for @tables from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
# Build our hash of prefixed table name to table object.
|
||||
foreach my $table (@tables) {
|
||||
$self->debug("CREATING GT::SQL::Table OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
my $tmp = $self->new_table($table);
|
||||
my $name = $tmp->name;
|
||||
push @$tables_ord, $name;
|
||||
$tables->{$name} = $tmp;
|
||||
}
|
||||
|
||||
# Get our driver, class name and key to look up subclasses (without prefixes).
|
||||
my $class = 'GT::SQL::Relation';
|
||||
my $prefix = $self->{connect}->{PREFIX};
|
||||
my $subclass_key = join "\0", map { s/^$prefix//; $_ } sort keys %{$tables};
|
||||
|
||||
# Look for any subclass to use, and load any error messages.
|
||||
no strict 'refs';
|
||||
|
||||
foreach my $table (values %{$tables}) {
|
||||
my $subclass = $table->subclass;
|
||||
if ((!exists $self->{subclass} or $self->{subclass}) and exists $subclass->{relation}->{$prefix . $subclass_key}) {
|
||||
$class = $subclass->{relation}->{$prefix . $subclass_key};
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : next;
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
}
|
||||
}
|
||||
use strict 'refs';
|
||||
|
||||
# Load our relation object.
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
$self->_load_module($class) or return;
|
||||
|
||||
my $rel = $class->new(
|
||||
tables => $tables,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect},
|
||||
_err_pkg => 'GT::SQL::Relation',
|
||||
tables_ord => $tables_ord
|
||||
);
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $rel if ($self->{connect}->{obj_cache});
|
||||
|
||||
return $rel;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# CREATOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
$COMPILE{creator} = __LINE__ . <<'END_OF_SUB';
|
||||
sub creator {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a creator object. Takes a table name as argument.
|
||||
# my $creator = $db->creator('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->creator(\'tablename\')');
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'creator()');
|
||||
my $name = $self->{connect}->{PREFIX} . $table_name;
|
||||
|
||||
# Create either an empty schema or use an old one.
|
||||
$self->debug("Creating new GT::SQL::Table object '$table_name' to be used in Creator.") if ($self->{_debug} > 2);
|
||||
my $table = GT::SQL::Table->new(
|
||||
name => $table_name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Creator'
|
||||
);
|
||||
|
||||
# Return a creator object.
|
||||
require GT::SQL::Creator;
|
||||
$self->debug("CREATING GT::SQL::Creator OBJECT") if $self->{_debug} > 2;
|
||||
return GT::SQL::Creator->new(
|
||||
table => $table,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a driver object, and connects.
|
||||
#
|
||||
my $self = shift;
|
||||
return 1 if $self->{driver};
|
||||
$self->{connect} or return $self->fatal('NOCONNECT');
|
||||
|
||||
my $driver = uc $self->{connect}->{driver} || 'MYSQL';
|
||||
$self->{driver} = GT::SQL::Driver->load_driver(
|
||||
$driver,
|
||||
schema => $self->{tables} || $self->{schema},
|
||||
name => scalar $self->name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => $self->{_err_pkg}
|
||||
) or return $self->fatal(CANTLOAD => $driver, $GT::SQL::error);
|
||||
|
||||
unless ($self->{driver}->connect) {
|
||||
delete $self->{driver};
|
||||
return;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub count {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->count;
|
||||
# ------------
|
||||
# Returns the number of tuples handled
|
||||
# by this relation.
|
||||
#
|
||||
# $obj->count($condition);
|
||||
# -------------------------
|
||||
# Returns the number of tuples that matches
|
||||
# that $condition.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cond;
|
||||
if (!ref $_[0] and @_ % 2 == 0 and defined $_[0]) {
|
||||
push @cond, {@_};
|
||||
}
|
||||
else {
|
||||
for (@_) {
|
||||
return $self->fatal(BADARGS => 'Arguments to count() must either be a hash, or one or more hash refs and/or GT::SQL::Condition objects')
|
||||
unless ref eq 'GT::SQL::Condition' or ref eq 'HASH';
|
||||
push @cond, $_;
|
||||
}
|
||||
}
|
||||
my $sel_opts = $self->{sel_opts};
|
||||
$self->{sel_opts} = [];
|
||||
my $sth = $self->select('COUNT(*)' => @cond ? GT::SQL::Condition->new(@cond) : ()) or return;
|
||||
$self->{sel_opts} = $sel_opts;
|
||||
return int $sth->fetchrow;
|
||||
}
|
||||
|
||||
$COMPILE{total} = __LINE__ . <<'END_OF_SUB';
|
||||
sub total {
|
||||
# -------------------------------------------------------------------
|
||||
# total()
|
||||
# IN : none
|
||||
# OUT: total number of records in table
|
||||
#
|
||||
shift->count
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{quote} = __LINE__ . <<'END_OF_SUB';
|
||||
sub quote {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->quote($value);
|
||||
# ---------------------
|
||||
# Returns the quoted representation of $value.
|
||||
#
|
||||
return GT::SQL::Driver::quote(pop)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{hits} = __LINE__ . <<'END_OF_SUB';
|
||||
sub hits {
|
||||
# -----------------------------------------------------------
|
||||
# hits()
|
||||
# IN : none
|
||||
# OUT: number of results in last search. (calls count(*) on
|
||||
# demand from hits() or toolbar())
|
||||
#
|
||||
my $self = shift;
|
||||
if (! defined $self->{last_hits}) {
|
||||
$self->{last_hits} = (defined $self->{last_where} ? $self->count($self->{last_where}) : $self->count) || 0;
|
||||
}
|
||||
return $self->{last_hits};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_cgi_to_hash} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _cgi_to_hash {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# $self->_cgi_to_hash($in);
|
||||
# --------------------------
|
||||
# Creates a hash ref from a cgi object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
defined $cgi and ref $cgi =~ /CGI/ or return $self->fatal(BADARGS => "'$cgi' is not a CGI object");
|
||||
|
||||
my @keys = $cgi->param;
|
||||
my $result = {};
|
||||
for my $key (@keys) {
|
||||
my @values = $cgi->param($key);
|
||||
$result->{$key} = @values == 1 ? $values[0] : \@values;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_get_search_opts} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _get_search_opts {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# _get_search_opts($hash_ref);
|
||||
# ----------------------------
|
||||
# Gets the search options based on the hash ref
|
||||
# passed in.
|
||||
#
|
||||
# sb => field_list # Return results sorted by field list.
|
||||
# so => [ASC|DESC] # Sort order of results.
|
||||
# mh => n # Return n results maximum, default to 25.
|
||||
# nh => n # Return the n'th set of results, default to 1.
|
||||
# rs => [col, col2] # A list of columns you want returned
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt_r = shift;
|
||||
my $ret = {};
|
||||
$ret->{nh} = (defined $opt_r->{nh} and $opt_r->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$ret->{mh} = (defined $opt_r->{mh} and $opt_r->{mh} =~ /^(-?\d+)$/) ? $1 : 25;
|
||||
$ret->{so} = (defined $opt_r->{so} and $opt_r->{so} =~ /^(ASC|DESC)$/i) ? $1 : '';
|
||||
$ret->{sb} = (defined $opt_r->{sb} and $opt_r->{sb} =~ /^([\w\s,.]+)$/) ? $1 : '';
|
||||
|
||||
# You can pass in 'Col ASC, Col2 DESC' in {sb} so we need to remove sort order then.
|
||||
if ((lc $ret->{sb}) =~ /\s(?:asc|desc)/) {
|
||||
$ret->{so} = '';
|
||||
}
|
||||
if (defined $ret->{rs} and ref $ret->{rs} eq 'ARRAY') {
|
||||
my @valid;
|
||||
foreach my $col (@{$ret->{rs}}) {
|
||||
$col =~ /^([\w\s,]+)$/ and push @valid, $1;
|
||||
}
|
||||
$ret->{rs} = \@valid;
|
||||
}
|
||||
else {
|
||||
$ret->{rs} = (defined $opt_r->{rs} and $opt_r->{rs} =~ /^([\w\s,]+)$/) ? $1 : '';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Transitional support. build_query_cond _was_ a private method
|
||||
$COMPILE{_build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _build_query_cond {
|
||||
my $self = shift;
|
||||
warn "obj->_build_query_cond() is deprecated; use obj->build_query_cond()" if $self->{_debug};
|
||||
$self->build_query_cond(@_)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub build_query_cond {
|
||||
# -------------------------------------------------------------------
|
||||
# Builds a condition object based on form input.
|
||||
# field_name => value # Find all rows with field_name = value
|
||||
# field_name => ">=?value" # Find all rows with field_name > or >= value.
|
||||
# field_name => "<=?value" # Find all rows with field_name < or <= value.
|
||||
# field_name => "!value" # Find all rows with field_name != value.
|
||||
# field_name-opt => >=?|<=?|=|<>|LIKE|STARTS|ENDS
|
||||
# # Find all rows with field_name (whichever) value.
|
||||
# field_name-gt => value # Find all rows with field_name > value.
|
||||
# field_name-lt => value # Find all rows with field_name < value.
|
||||
# field_name-ge => value # Find all rows with field_name >= value.
|
||||
# field_name-le => value # Find all rows with field_name <= value.
|
||||
# field_name-ne => value # Find all rows with field_name != value.
|
||||
# keyword => value # Find all rows where any field_name = value
|
||||
# query => value # Find all rows using GT::SQL::Search module
|
||||
# ww => 1 # 1 => use = comparision, 0/unspecified => use LIKE '%value%' comparision
|
||||
# ma => 1 # 1 => OR match 0/unspecified => AND match
|
||||
#
|
||||
my ($self, $opts, $c) = @_;
|
||||
|
||||
my $cond = new GT::SQL::Condition;
|
||||
my ($cmp, $l);
|
||||
($cmp, $l) = $opts->{ww} ? ('=', '') : ('LIKE', '%');
|
||||
$cond->boolean($opts->{ma} ? 'OR' : 'AND');
|
||||
my $ins = 0;
|
||||
|
||||
# First find the fields and find what we
|
||||
# want to do with them.
|
||||
if (defined $opts->{query} and $opts->{query} =~ /\S/) {
|
||||
require GT::SQL::Search;
|
||||
my $search = GT::SQL::Search->load_search({
|
||||
%{$opts},
|
||||
db => $self->{driver},
|
||||
table => $self,
|
||||
debug => $self->{debug},
|
||||
_debug => $self->{_debug}
|
||||
});
|
||||
my $sth = $search->query();
|
||||
$self->{last_hits} = $search->rows();
|
||||
$self->{rejected_keywords} = $search->{rejected_keywords};
|
||||
return $sth;
|
||||
}
|
||||
elsif (defined $opts->{keyword} and ($opts->{keyword} ne "") and ($opts->{keyword} ne '*')) {
|
||||
my $val = $opts->{keyword};
|
||||
my $is_dig = $val =~ /^[+-]*\d+\.?\d*$/;
|
||||
|
||||
foreach my $field (keys %$c) {
|
||||
next unless (index($c->{$field}->{type}, 'DATE') == -1); # No DATE fields.
|
||||
next unless (index($c->{$field}->{type}, 'TIME') == -1); # No TIME fields.
|
||||
next unless (index($c->{$field}->{type}, 'ENUM') == -1); # No ENUM fields.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'INT') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'DECIMAL') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'FLOAT') != -1)); # No ints if not an int.
|
||||
|
||||
$cond->add($field, $cmp, "$l$opts->{keyword}$l");
|
||||
$ins = 1;
|
||||
}
|
||||
$cond->bool('OR');
|
||||
}
|
||||
else {
|
||||
|
||||
# Go through each column and build condition.
|
||||
foreach my $field (keys %$c) {
|
||||
my $comp = $cmp;
|
||||
my $s = $l;
|
||||
my $e = $l;
|
||||
my @ins;
|
||||
|
||||
if ($opts->{"$field-opt"}) {
|
||||
$comp = uc $opts->{"$field-opt"};
|
||||
|
||||
$s = $e = '';
|
||||
if ( $comp eq 'LIKE' ) {
|
||||
$e = $s = '%';
|
||||
}
|
||||
elsif ( $comp eq 'STARTS' ) {
|
||||
$comp = 'LIKE';
|
||||
$e = '%';
|
||||
}
|
||||
elsif ( $comp eq 'ENDS' ) {
|
||||
$comp = 'LIKE';
|
||||
$s = '%';
|
||||
}
|
||||
|
||||
}
|
||||
else {
|
||||
if ($c->{$field}->{type} =~ /ENUM/i) {
|
||||
$comp = '=';
|
||||
$e = $s = '';
|
||||
}
|
||||
}
|
||||
|
||||
# Comp can only be: =, <, >, <=, >=, <>, LIKE, STARTS, ENDS
|
||||
$comp = '=' unless $comp =~ /^(=|<=?|>=?|<>|LIKE)$/i;
|
||||
|
||||
if (exists $opts->{"$field-gt"} and ($opts->{"$field-gt"} ne "")) {
|
||||
push @ins, [$field, '>', $opts->{$field . "-gt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-lt"} and ($opts->{"$field-lt"} ne "")) {
|
||||
push @ins, [$field, '<', $opts->{$field . "-lt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-ge"} and ($opts->{"$field-ge"} ne "")) {
|
||||
push @ins, [$field, '>=', $opts->{$field . "-ge"}];
|
||||
}
|
||||
if (exists $opts->{"$field-le"} and ($opts->{"$field-le"} ne "")) {
|
||||
push @ins, [$field, '<=', $opts->{$field . "-le"}];
|
||||
}
|
||||
|
||||
if (exists $opts->{"$field-ne"} and ($opts->{"$field-ne"} ne "")) {
|
||||
my $c = new GT::SQL::Condition;
|
||||
$c->add($field => '!=' => $opts->{"$field-ne"});
|
||||
}
|
||||
|
||||
if (exists $opts->{$field} and ($opts->{$field} ne "")) {
|
||||
if (ref($opts->{$field}) eq 'ARRAY' ) {
|
||||
my $add = [];
|
||||
for ( @{$opts->{$field}} ) {
|
||||
next if !defined( $_ ) or !length( $_ ) or !/\S/;
|
||||
push @$add, $_;
|
||||
}
|
||||
if ( @$add ) {
|
||||
push @ins, [$field, 'IN', $add];
|
||||
}
|
||||
}
|
||||
elsif ($opts->{$field} =~ /^(>=?|<=?|!)(.*)/) {
|
||||
push @ins, [$field, ($1 eq '!') ? '<>' : $1, $2];
|
||||
}
|
||||
elsif ($opts->{$field} eq '+') {
|
||||
push @ins, [$field, "<>", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '-') {
|
||||
push @ins, [$field, "=", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '*') {
|
||||
if ($opts->{"$field-opt"} and ($opts->{"$field-opt"} eq '<>')) {
|
||||
push @ins, [$field, '=', ''];
|
||||
}
|
||||
else {
|
||||
next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
substr($opts->{$field}, 0, 1) = "" if substr($opts->{$field}, 0, 1) eq '\\';
|
||||
push @ins, [$field, $comp, "$s$opts->{$field}$e"];
|
||||
}
|
||||
}
|
||||
|
||||
if (@ins) {
|
||||
for (@ins) {
|
||||
$cond->add($_);
|
||||
}
|
||||
$ins = 1;
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
return $ins ? $cond : '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _load_module {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a subclassed module.
|
||||
#
|
||||
my ($self, $class) = @_;
|
||||
|
||||
no strict 'refs';
|
||||
return 1 if (UNIVERSAL::can($class, 'new'));
|
||||
|
||||
(my $pkg = $class) =~ s,::,/,g;
|
||||
my $ok = 0;
|
||||
my @err = ();
|
||||
until ($ok) {
|
||||
local ($@, $SIG{__DIE__});
|
||||
eval { require "$pkg.pm" };
|
||||
if ($@) {
|
||||
push @err, $@;
|
||||
# In case the module had compile errors, %class:: will be defined, but not complete.
|
||||
undef %{$class . '::'} if defined %{$class . '::'};
|
||||
}
|
||||
else {
|
||||
$ok = 1;
|
||||
last;
|
||||
}
|
||||
my $pos = rindex($pkg, '/');
|
||||
last if $pos == -1;
|
||||
substr($pkg, $pos) = "";
|
||||
}
|
||||
unless ($ok and UNIVERSAL::can($class, 'new')) {
|
||||
return $self->fatal(BADSUBCLASS => $class, join ", ", @err);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
404
site/glist/lib/GT/SQL/Condition.pm
Normal file
404
site/glist/lib/GT/SQL/Condition.pm
Normal file
@ -0,0 +1,404 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Condition.pm,v 1.44 2004/10/12 17:54:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements an SQL condition.
|
||||
#
|
||||
|
||||
package GT::SQL::Condition;
|
||||
# ===============================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $VERSION/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.44 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->new;
|
||||
# $obj->new;
|
||||
# ----------
|
||||
# This class method is the base constructor for the GT::SQL::Condition
|
||||
# object. It can be passed the boolean operator that has to be used for that
|
||||
# object ("AND" is the default), the conditions for this object.
|
||||
#
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
my $self = {
|
||||
cond => [],
|
||||
not => 0,
|
||||
bool => 'AND'
|
||||
};
|
||||
bless $self, $class;
|
||||
|
||||
if (@_ and defined $_[$#_] and (uc $_[$#_] eq 'AND' or uc $_[$#_] eq 'OR' or $_[$#_] eq ',') ) {
|
||||
$self->boolean(uc pop);
|
||||
}
|
||||
$self->add(@_) if @_;
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{clone} = __LINE__ . <<'END_OF_SUB';
|
||||
sub clone {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Clones the current object - that is, gives you an identical object that
|
||||
# doesn't reference the original at all.
|
||||
#
|
||||
my $self = shift;
|
||||
my $newself = { not => $self->{not}, bool => $self->{bool} };
|
||||
bless $newself, ref $self;
|
||||
my @cond;
|
||||
|
||||
for (@{$self->{cond}}) {
|
||||
# {cond} can contain two things - three-value array references
|
||||
# ('COL', '=', 'VAL'), or full-fledged condition objects.
|
||||
if (ref eq 'ARRAY') {
|
||||
push @cond, [@$_];
|
||||
}
|
||||
elsif (UNIVERSAL::isa($_, __PACKAGE__)) {
|
||||
push @cond, $_->clone;
|
||||
}
|
||||
}
|
||||
$newself->{cond} = \@cond;
|
||||
$newself;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{not} = __LINE__ . <<'END_OF_SUB';
|
||||
sub not {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->not;
|
||||
# ----------------
|
||||
# Negates the current condition.
|
||||
#
|
||||
$_[0]->{not} = 1;
|
||||
return $_[0];
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
|
||||
$COMPILE{new_clean} = __LINE__ . <<'END_OF_SUB';
|
||||
sub new_clean {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->new_clean;
|
||||
# ----------------
|
||||
# Returns the same condition object, but ready to be prepared again.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
my $res = $class->new;
|
||||
$res->boolean($self->boolean);
|
||||
for my $cond (@{$self->{cond}}) {
|
||||
$res->add($cond);
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub boolean {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->boolean;
|
||||
# --------------
|
||||
# Returns the boolean operator which is being used for the current object.
|
||||
#
|
||||
# $obj->boolean($string);
|
||||
# ------------------------
|
||||
# Sets $string as the boolean operator for this condition object. Typically
|
||||
# this should be nothing else than "AND" or "OR", but no checks are
|
||||
# performed, so watch out for typos!
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{bool} = shift || return $self->{bool};
|
||||
}
|
||||
|
||||
sub add {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->add($col => $op => $val [, $col2 => $op2 => $val2, ...]);
|
||||
# ----------------------------
|
||||
# Adds a one or more COL OP VAL clauses to the current condition.
|
||||
#
|
||||
# $obj->add($condition [, $cond2, ...]);
|
||||
# -----------------------
|
||||
# Adds one or more condition clauses to the current condition.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
while (@_) {
|
||||
my $var = shift;
|
||||
if (ref $var eq 'ARRAY' or UNIVERSAL::isa($var, __PACKAGE__)) {
|
||||
push @{$self->{cond}}, $var;
|
||||
}
|
||||
elsif (ref $var eq 'HASH') {
|
||||
for (keys %$var) {
|
||||
push @{$self->{cond}}, [$_ => '=' => $var->{$_}];
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $op = @_ >= 2 ? shift || '=' : '='; # To support $cond->add(foo => $bar);
|
||||
my $val = shift;
|
||||
if (not defined $val) {
|
||||
if ($op eq '=' and $self->{bool} ne ',') {
|
||||
$op = 'IS';
|
||||
}
|
||||
elsif ($op eq '!=' or $op eq '<>') {
|
||||
$op = 'IS NOT';
|
||||
}
|
||||
}
|
||||
push @{$self->{cond}}, [$var => $op => $val];
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub sql {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a string for the current SQL object which is the SQL representation
|
||||
# of that condition. The string can then be inserted after a SQL WHERE clause.
|
||||
# Optionally takes an option which, if true, uses placeholders and returns
|
||||
# ($sql, \@values, \@columns) instead of just $sql.
|
||||
#
|
||||
my ($self, $ph) = @_;
|
||||
my $bool = $self->{bool};
|
||||
my (@vals, @cols, @output);
|
||||
|
||||
foreach my $cond (@{$self->{cond}}) {
|
||||
if (ref $cond eq 'ARRAY') {
|
||||
my ($col, $op, $val) = @$cond;
|
||||
# Perl: column => '=' => [1,2,3]
|
||||
# SQL: column IN (1,2,3)
|
||||
if (uc $op eq 'IN' || $op eq '=' and ref $val eq 'ARRAY') {
|
||||
if (@$val > 1) {
|
||||
$op = 'IN';
|
||||
$val = '('
|
||||
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
||||
. ')';
|
||||
}
|
||||
elsif (@$val == 0) {
|
||||
($col, $op, $val) = (qw(1 = 0));
|
||||
}
|
||||
else {
|
||||
$op = '=';
|
||||
$val = quote($val->[0]);
|
||||
}
|
||||
push @output, "$col $op $val";
|
||||
}
|
||||
# Perl: column => '!=' => [1,2,3]
|
||||
# SQL: NOT(column IN (1,2,3))
|
||||
elsif ($op eq '!=' || $op eq '<>' and ref $val eq 'ARRAY') {
|
||||
my $output;
|
||||
if (@$val > 1) {
|
||||
$output = "NOT ($col IN ";
|
||||
$output .= '('
|
||||
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
||||
. ')';
|
||||
$output .= ')';
|
||||
}
|
||||
elsif (@$val == 0) {
|
||||
$output = '1 = 1';
|
||||
}
|
||||
else {
|
||||
$output = "$col $op " . quote($val->[0]);
|
||||
}
|
||||
push @output, $output;
|
||||
}
|
||||
elsif ($ph and defined $val and not ref $val) {
|
||||
push @output, "$col $op ?";
|
||||
push @cols, $col;
|
||||
push @vals, $val;
|
||||
}
|
||||
else {
|
||||
push @output, "$col $op " . quote($val);
|
||||
}
|
||||
}
|
||||
elsif (UNIVERSAL::isa($cond, __PACKAGE__)) {
|
||||
my @sql = $cond->sql($ph);
|
||||
if ($sql[0]) {
|
||||
push @output, "($sql[0])";
|
||||
if ($ph) {
|
||||
push @vals, @{$sql[1]};
|
||||
push @cols, @{$sql[2]};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
my $final = join " $bool ", @output;
|
||||
$final &&= "NOT ($final)" if $self->{not};
|
||||
|
||||
return wantarray ? ($final, $ph ? (\@vals, \@cols) : ()) : $final;
|
||||
}
|
||||
|
||||
$COMPILE{sql_ph} = __LINE__ . <<'END_OF_SUB';
|
||||
sub sql_ph {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Depreciated form of ->sql(1);
|
||||
shift->sql(1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------------------------
|
||||
# this subroutines quotes (or not) a value given its column.
|
||||
#
|
||||
defined(my $val = pop) or return 'NULL';
|
||||
return ref $val eq 'SCALAR' ? $$val : GT::SQL::Driver->quote($val);
|
||||
}
|
||||
|
||||
sub as_hash {
|
||||
# -----------------------------------------------------------------------------
|
||||
# returns the condition object as a flattened hash.
|
||||
#
|
||||
my $cond = shift;
|
||||
ref $cond eq 'HASH' and return $cond;
|
||||
my %ret;
|
||||
for my $arr (@{$cond->{cond}}) {
|
||||
if (ref $arr eq 'ARRAY') {
|
||||
$ret{$arr->[0]} = $arr->[2];
|
||||
}
|
||||
else {
|
||||
my $h = as_hash($arr);
|
||||
for my $k (keys %$h) {
|
||||
$ret{$k} = $h->{$k};
|
||||
}
|
||||
}
|
||||
}
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL::Condition - Creates complex where clauses
|
||||
|
||||
=head1 SYNOPSYS
|
||||
|
||||
my $cond = GT::SQL::Condition->new(Column => LIKE => 'foo%');
|
||||
print $cond->sql;
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
Column => LIKE => 'foo%',
|
||||
Column2 => '<' => 'abc'
|
||||
);
|
||||
$cond->bool('OR');
|
||||
print $cond->sql;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The condition module is useful for generating complex SQL WHERE clauses. At
|
||||
it's simplest, a condition is composed of three parts: column, condition and
|
||||
value.
|
||||
|
||||
Here are some examples.
|
||||
|
||||
To find all users with a first name that starts with Alex use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(FirstName => LIKE => 'Alex%');
|
||||
|
||||
To find users with first name like alex, B<and> last name like krohn use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%'
|
||||
);
|
||||
|
||||
To find users with first name like alex B<or> last name like krohn use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%'
|
||||
);
|
||||
$cond->bool('OR');
|
||||
|
||||
You may also specify this as:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%',
|
||||
'OR'
|
||||
);
|
||||
|
||||
Now say we wanted something a bit more complex that would normally involve
|
||||
setting parentheses. We want to find users who have either first name like alex
|
||||
or last name like krohn, and whose employer is Gossamer Threads. We could use:
|
||||
|
||||
my $cond1 = GT::SQL::Condition->new(
|
||||
'FirstName', 'LIKE', 'Alex%',
|
||||
'LastName', 'LIKE', 'Krohn%'
|
||||
);
|
||||
$cond1->bool('or');
|
||||
my $cond2 = GT::SQL::Condition->new(
|
||||
$cond1,
|
||||
Employer => '=' => 'Gossamer Threads'
|
||||
);
|
||||
|
||||
By default, all values are quoted, so you don't need to bother using any quote
|
||||
function. If you don't want something quoted (say you want to use a function
|
||||
for example), then you pass in a reference.
|
||||
|
||||
For example, to find users who have a last name that sounds like 'krohn', you
|
||||
could use your SQL engines SOUNDEX function:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(LastName => '=' => \"SOUNDEX('krohn')");
|
||||
|
||||
and the right side wouldn't be quoted.
|
||||
|
||||
You can also use a condition object to specify a list of multiple values, which
|
||||
will become the SQL 'IN' operator. For example, to match anyone with a first
|
||||
name of Alex, Scott or Jason, you can do:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(FirstName => IN => ['Alex', 'Scott', 'Jason']);
|
||||
|
||||
which will turn into:
|
||||
|
||||
FirstName IN ('Alex', 'Scott', 'Jason')
|
||||
|
||||
Note that when using multiple values, you can use '=' instead of 'IN'. Empty
|
||||
lists will be treated as an impossible condition (1 = 0). This is primarily
|
||||
useful for list handling list of id numbers.
|
||||
|
||||
To match NULL values, you can use C<undef> for the value passed to the add()
|
||||
method. If specifying '=' as the operator, it will automatically be changed to
|
||||
'IS':
|
||||
|
||||
$cond->add(MiddleName => '=' => undef);
|
||||
|
||||
becomes:
|
||||
|
||||
MiddleName IS NULL
|
||||
|
||||
|
||||
To negate your queries you can use the C<not> function.
|
||||
|
||||
my $cond = GT::SQL::Condition->new(a => '=' => 5);
|
||||
$cond->not;
|
||||
|
||||
would translate into NOT (a = '5'). You can also do this all on one line like:
|
||||
|
||||
print GT::SQL::Condition->new(a => '=' => '5')->not->sql;
|
||||
|
||||
This returns the sql right away.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Condition.pm,v 1.44 2004/10/12 17:54:30 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1216
site/glist/lib/GT/SQL/Creator.pm
Normal file
1216
site/glist/lib/GT/SQL/Creator.pm
Normal file
File diff suppressed because it is too large
Load Diff
887
site/glist/lib/GT/SQL/Display/HTML.pm
Normal file
887
site/glist/lib/GT/SQL/Display/HTML.pm
Normal file
@ -0,0 +1,887 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: HTML.pm,v 1.92 2005/04/05 18:47:08 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS $INPUT_SEPARATOR/;
|
||||
use GT::Base;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.92 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$INPUT_SEPARATOR = "\n";
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
mode => '',
|
||||
code => {},
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
hide_download => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
url => $ENV{REQUEST_URI},
|
||||
};
|
||||
|
||||
sub init {
|
||||
# ---------------------------------------------------------------
|
||||
# new() comes from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Set any passed in options.
|
||||
$self->set (@_);
|
||||
|
||||
# Try to set the URL
|
||||
$self->{url} or eval { require GT::CGI; $self->{url} = GT::CGI->url(); };
|
||||
$self->{url} ||= '';
|
||||
|
||||
# Make sure we have a database object.
|
||||
# exists ($self->{db}) and (ref $self->{db}) or return $self->error ("BADARGS", "FATAL", "You must pass in a GT::SQL::Table object");
|
||||
|
||||
my $input = ref $self->{input};
|
||||
if ($input and ($input eq 'GT::CGI')) {
|
||||
$self->{input} = $self->{input}->get_hash;
|
||||
}
|
||||
elsif ($input and ($input eq 'CGI')) {
|
||||
my $h = {};
|
||||
foreach my $key ($self->{input}->param) {
|
||||
$h->{$key} = $self->{input}->param($key);
|
||||
}
|
||||
$self->{input} = $h;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub reset_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Resets the display options.
|
||||
#
|
||||
my $self = shift;
|
||||
while (my ($k, $v) = each %$ATTRIBS) {
|
||||
next if $k eq 'db';
|
||||
next if $k eq 'disp_form';
|
||||
next if $k eq 'disp_html';
|
||||
next if $k eq 'input';
|
||||
if (! ref $v) {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$self->{$k} = {};
|
||||
foreach my $k1 (keys %{$ATTRIBS->{$k}}) { $self->{$k}->{$k1} = $ATTRIBS->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$self->{$k} = [];
|
||||
foreach my $v1 (@{$ATTRIBS->{$k}}) { push @{$self->{$k}}, $v1; }
|
||||
}
|
||||
else { $self->{$k} = $v; }
|
||||
}
|
||||
}
|
||||
|
||||
sub form {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as an html form.
|
||||
#
|
||||
my $self = shift;
|
||||
$_[0]->{disp_form} = 1;
|
||||
$_[0]->{disp_html} = 0;
|
||||
return $self->_display (@_);
|
||||
}
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->error ("NEEDSUBCLASS", "FATAL")
|
||||
}
|
||||
|
||||
sub _get_defaults {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns default values for fields. Bases it on what's passed in,
|
||||
# cgi input, def file defaults, otherwise blank.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $c = $self->{cols} || $self->{db}->cols;
|
||||
my $values = {};
|
||||
foreach my $col (@cols) {
|
||||
my $value = '';
|
||||
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
||||
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
||||
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
||||
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
($c->{$col}->{default} =~ /0000/)
|
||||
? ($value = $self->_get_time($c->{$col}))
|
||||
: ($value = $c->{$col}->{default});
|
||||
}
|
||||
else {
|
||||
$value = $c->{$col}->{default};
|
||||
}
|
||||
}
|
||||
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
$value = $self->_get_time($c->{$col});
|
||||
}
|
||||
if ($c->{$col}->{form_type} and uc $c->{$col}->{form_type} eq 'FILE' ) {
|
||||
$values->{$col."_filename"} = $self->{values}->{$col."_filename"};
|
||||
}
|
||||
$values->{$col} = $value;
|
||||
}
|
||||
return $values;
|
||||
}
|
||||
|
||||
sub _skip {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $col) = @_;
|
||||
|
||||
# Skip timestamps, any fields requested to be skipped or any hidden fields (hidden forms appended at bottom).
|
||||
return 1 if ($self->{hide_timestamp} and $self->{cols}->{$col}->{time_check});
|
||||
return 1 if ($self->{skip} and (grep /^$col$/, @{$self->{skip}}));
|
||||
return 1 if ($self->{hide} and (grep /^$col$/, @{$self->{hide}}));
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _get_form_display {
|
||||
my ($self, $col) = @_;
|
||||
|
||||
if (
|
||||
($self->{view_key} and
|
||||
exists $self->{cols}->{$col}->{time_check} and
|
||||
$self->{cols}->{$col}->{time_check})
|
||||
||
|
||||
($self->{view} and (grep /^$col$/, @{$self->{view}}))
|
||||
)
|
||||
{
|
||||
return 'hidden_text';
|
||||
}
|
||||
|
||||
my $form_type = lc $self->{cols}->{$col}->{form_type} or return 'default';
|
||||
|
||||
if ( $form_type eq 'password' and index( $self->{mode}, 'search_form' ) + 1 ) {
|
||||
return 'default'
|
||||
}
|
||||
|
||||
elsif ( $form_type and $self->can( $form_type ) ) {
|
||||
return $form_type;
|
||||
}
|
||||
|
||||
return 'default';
|
||||
}
|
||||
|
||||
sub _get_html_display {
|
||||
my $self = shift;
|
||||
my $col = shift;
|
||||
return 'display_text';
|
||||
}
|
||||
|
||||
# Form types
|
||||
sub default {
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_char_form");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_char_form");
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $size = exists $opts->{form_size} ? $opts->{form_size} : (exists $def->{form_size} ? ($def->{form_size} || 30) : 30);
|
||||
my $max = exists $opts->{size} ? $opts->{def}->{size} : (exists $def->{size} ? $def->{size} : 255);
|
||||
|
||||
defined ($val) or $val = '';
|
||||
_escape(\$val);
|
||||
return qq~<input type="TEXT" name="$name" value="$val" maxlength="$max" size="$size">~;
|
||||
}
|
||||
|
||||
sub date {
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{form_size} ||= 20;
|
||||
return $self->text ($opts);
|
||||
}
|
||||
|
||||
sub multiple { shift->select (@_) }
|
||||
|
||||
sub select {
|
||||
# ---------------------------------------------------------------
|
||||
# Make a select list. Valid options are:
|
||||
# name => FORM_NAME
|
||||
# values => { form_value => displayed_value }
|
||||
# value => selected_value
|
||||
# or
|
||||
# value => [selected_value1, selected_value2]
|
||||
# multiple => n - adds MULTIPLE SIZE=n to select list
|
||||
# sort => coderef called to sort the list or array ref specifying the order in
|
||||
# which the fields should be display. A code ref, when called, will be
|
||||
# passed the following arguments: ($value{$a}, $value{$b}, $a, $b)
|
||||
# blank => 1 or 0. If true, a blank first option will be printed, if false
|
||||
# the blank first element will not be printed. Defaults to true.
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS1", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Get the default value to display if nothing is selected.
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my ($sort_f, $sort_o);
|
||||
if (ref $opts->{sort} eq 'CODE') {
|
||||
$sort_f = $opts->{sort};
|
||||
}
|
||||
elsif (ref $opts->{sort} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort};
|
||||
}
|
||||
# sort_order => [...] has been replaced with sort => [...] and so it
|
||||
# is NOT mentioned in the subroutine comments.
|
||||
elsif (ref $opts->{sort_order} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort_order};
|
||||
}
|
||||
my $blank = exists $opts->{blank} ? $opts->{blank} : 1;
|
||||
|
||||
# Multiple was passed in
|
||||
my $mult;
|
||||
my $clean_name = $name;
|
||||
if ($name =~ /^\d\-(.+)$/) {
|
||||
$clean_name = $1;
|
||||
}
|
||||
if (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_type} and $self->{cols}->{$clean_name}->{form_type} eq 'MULTIPLE') {
|
||||
$mult = qq!MULTIPLE SIZE="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
elsif (exists $opts->{multiple} and $opts->{multiple} > 1) {
|
||||
$mult = qq!MULTIPLE SIZE="$opts->{multiple}"!;
|
||||
}
|
||||
elsif (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_size}) {
|
||||
$mult = qq!SIZE="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
else {
|
||||
$mult = '';
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
my $out = qq~<select $mult name="$name"$class>~;
|
||||
$blank and ($out .= qq~<option value="">---</option>~);
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->($hash{$a}, $hash{$b}, $a, $b) } keys %hash }
|
||||
else { @keys = @$names; }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = { map { ($_ => 1) } split (/\Q$INPUT_SEPARATOR\E%?/o, $def) };
|
||||
}
|
||||
else { # Array ref
|
||||
$def = { map { ($_ => 1) } @$def };
|
||||
}
|
||||
for my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
$out .= qq~<option value="$key"~;
|
||||
$out .= " selected" if $def->{$key};
|
||||
$out .= ">$val</option>";
|
||||
}
|
||||
$out .= "</select>\n";
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub radio {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a radio series.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No name for field passed to radio");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash; }
|
||||
else { @keys = keys %hash; }
|
||||
|
||||
(ref $def eq 'ARRAY') or ($def = [$def]);
|
||||
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~$val<input type="radio" value="$key"$class name="$name" checked> ~) and next KEY;
|
||||
}
|
||||
$out .= qq~$val<input name="$name" type="radio" value="$key"$class> ~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub checkbox {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a checkbox set.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash }
|
||||
else { @keys = keys %hash }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = [sort split (/\Q$INPUT_SEPARATOR\E%?/o, $def)];
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~ <input name="$name" type="checkbox" value="$key" checked$class>$val~) and next KEY;
|
||||
}
|
||||
$out .= qq~ <input name="$name" type="checkbox" value="$key"$class>$val~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub hidden {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a hidden field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
return qq~<input type="hidden" name="$name" value="$def">~;
|
||||
}
|
||||
|
||||
sub hidden_text {
|
||||
my ($self, $opts) = @_;
|
||||
my $out;
|
||||
my $html = $self->_get_html_display;
|
||||
$out .= "<font $self->{val_font}>";
|
||||
$out .= $self->$html($opts);
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
elsif (exists $opts->{def}->{time_check}) { $def = $self->_get_time ($opts->{def}) }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
$out .= qq~<input type="hidden" name="$opts->{name}" value="$def"></font>~;
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub file {
|
||||
# ---------------------------------------------------------------
|
||||
# creates a file field
|
||||
#
|
||||
# function is a bit large since it has to do a fair bit, with multiple options.
|
||||
#
|
||||
my ($self, $opts, $values, $display ) = @_;
|
||||
|
||||
$values ||= {};
|
||||
$self->{file_field} or return $self->text($opts);
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
|
||||
my $def = $opts->{def};
|
||||
my $out;
|
||||
my $colname = $opts->{name}; $colname =~ s,^\d*-,,;
|
||||
my $fname = $opts->{value};
|
||||
_escape(\$fname);
|
||||
|
||||
# Find out if the file exists
|
||||
my $tbl = $display->{db}->new_table( $dbname . "_Files" ) or return 'Associated _File table is missing';
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return 'File handling requires one primary key';
|
||||
|
||||
my $href = $tbl->get({ ForeignColName => $colname, ForeignColKey => $values->{$pk[0]} });
|
||||
unless ( ( not $href and not $self->{file_use_path} ) or
|
||||
( not ( -e $opts->{value}) and $self->{file_use_path} ) ) {
|
||||
|
||||
require GT::SQL::File;
|
||||
my $sfname = $values->{$colname."_filename"};
|
||||
$out = $sfname || GT::SQL::File::get_filename($fname ||= $href->{File_Name} );
|
||||
$self->{file_use_path} and $out .= qq!<input name="$opts->{name}_path" type=hidden value="$fname">!;
|
||||
$sfname and $out .= qq!<input type=hidden name="$opts->{name}_filename" type=hidden value="$sfname">!;
|
||||
|
||||
if ( $fname and $self->{file_delete} ) {
|
||||
|
||||
if ( $def->{form_type} =~ /^file$/i and not $self->{hide_downloads} and $self->{url} ) {
|
||||
my $url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'download_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => ( $self->{file_use_path} ? 'path' : 'db' ),
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size=1><i><a href="$url">download</a></i></font></font>!;
|
||||
$url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'view_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => ( $self->{file_use_path} ? 'path' : 'db' ),
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size=1><i><a href="$url" target=_blank>view</a></i></font></font>!;
|
||||
}
|
||||
$out .= qq~ <input type=checkbox name="$opts->{name}_del" value="delete"> Delete~;
|
||||
}
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
$out .= qq~<p><input type="file" name="$opts->{name}"$class>~;
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub text {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a text field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
return qq~<input type="text" name="$name" value="$def" size="$size"$class>~;
|
||||
}
|
||||
|
||||
sub password {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a password field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if ( $opts->{blank} ) { $def = '' } # keep the password element blank
|
||||
elsif (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
return qq~<input type="password" name="$name" value="$def" size="$size"$class>~;
|
||||
}
|
||||
|
||||
sub textarea {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a textarea.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my ($cols, $rows) = (ref $size) ? (@{$size}) : ($size, 4);
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
return qq~<textarea rows="$rows" cols="$cols" name="$name"$class>$def</textarea>~;
|
||||
}
|
||||
|
||||
sub display_text {
|
||||
# ---------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator display_text");
|
||||
my $values = shift;
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to view creator display_text (" . (caller())[2] . ")" );
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $pval = $val;
|
||||
defined $val or ($val = '');
|
||||
_escape(\$val);
|
||||
|
||||
# If they are using checkbox/radio/selects then we map form_names => form_values.
|
||||
if (ref $def->{form_names} and ref $def->{form_values}) {
|
||||
if (@{$def->{form_names}} and @{$def->{form_values}}) {
|
||||
my %map = map { $def->{form_names}->[$_] => $def->{form_values}->[$_] } (0 .. $#{$def->{form_names}});
|
||||
my @keys = split /\Q$INPUT_SEPARATOR\E|\n/, $val;
|
||||
$val = '';
|
||||
|
||||
foreach (@keys) {
|
||||
$val .= $map{$_} ? $map{$_} : $_;
|
||||
$val .= "<br>";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($def->{form_type} and uc $def->{form_type} eq 'FILE' and not $self->{hide_downloads} and $self->{url}) {
|
||||
$pval or return $val;
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
my $colname = $opts->{name}; $colname =~ s,^$dbname\.,,g;
|
||||
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return;
|
||||
my $url = _reparam_url( $self->{url}, { do => 'download_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size=1><i><a href="$url">download</a></i></font></font>!;
|
||||
|
||||
$url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size=1><i><a href="$url" target=_blank>view</a></i></font></font>!;
|
||||
}
|
||||
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _reparam_url {
|
||||
# ---------------------------------------------------------------
|
||||
my $orig_url = shift;
|
||||
my $add = shift || {};
|
||||
my $remove = shift || [];
|
||||
my %params = ();
|
||||
my $new_url = $orig_url;
|
||||
|
||||
# get the original parameters
|
||||
my $qloc = index( $orig_url, '?');
|
||||
if ( $qloc > 0 ) {
|
||||
require GT::CGI;
|
||||
$new_url = substr( $orig_url, 0, $qloc );
|
||||
my $base_parms = substr( $orig_url, $qloc+1 );
|
||||
$base_parms = GT::CGI::unescape($base_parms);
|
||||
|
||||
# now parse the parameters
|
||||
foreach my $param ( grep $_, split /[&;]/, $base_parms ) {
|
||||
my $eloc = index( $param, '=' );
|
||||
$eloc < 0 and push( @{$params{$param} ||= []}, undef ), next;
|
||||
my $key = substr( $param, 0, $eloc );
|
||||
my $value = substr( $param, $eloc+1 );
|
||||
push( @{$params{$key} ||= []}, $value);
|
||||
}
|
||||
}
|
||||
|
||||
# delete a few parameters
|
||||
foreach my $param ( @$remove ) { delete $params{$param}; }
|
||||
|
||||
# add a few parameters
|
||||
foreach my $key ( keys %$add ) {
|
||||
push( @{$params{$key} ||= []}, $add->{$key});
|
||||
}
|
||||
|
||||
# put everything together
|
||||
require GT::CGI;
|
||||
my @params;
|
||||
foreach my $key ( keys %params ) {
|
||||
foreach my $value ( @{$params{$key}} ) {
|
||||
push @params, GT::CGI::escape($key).'='.GT::CGI::escape($value);
|
||||
}
|
||||
}
|
||||
$new_url .= "?" . join( '&', @params );
|
||||
return $new_url;
|
||||
}
|
||||
|
||||
sub toolbar {
|
||||
# ---------------------------------------------------------------
|
||||
# Display/calculate a "next hits" toolbar.
|
||||
#
|
||||
my $class = shift;
|
||||
my ($nh, $maxhits, $numhits, $script) = @_;
|
||||
my ($next_url, $max_page, $next_hit, $prev_hit, $left, $right, $upper, $lower, $first, $url, $last, $i);
|
||||
|
||||
# Return if there shouldn't be a speedbar.
|
||||
return unless ($numhits > $maxhits);
|
||||
|
||||
# Strip nh=\d out of the query string, as we need to append it on. Try and keep
|
||||
# the url looking nice (i.e. no double ;&, or extra ?.
|
||||
$script =~ s/[&;]nh=\d+([&;]?)/$1/;
|
||||
$script =~ s/\?nh=\d+[&;]?/\?/;
|
||||
($script =~ /\?/) or ($script .= "?");
|
||||
$script =~ s/&/&/g;
|
||||
$next_hit = $nh + 1;
|
||||
$prev_hit = $nh - 1;
|
||||
$maxhits ||= 25;
|
||||
$max_page = int ($numhits / $maxhits) + (($numhits % $maxhits) ? 1 : 0);
|
||||
|
||||
# First, set how many pages we have on the left and the right.
|
||||
$left = $nh; $right = int($numhits/$maxhits) - $nh;
|
||||
# Then work out what page number we can go above and below.
|
||||
($left > 7) ? ($lower = $left - 7) : ($lower = 1);
|
||||
($right > 7) ? ($upper = $nh + 7) : ($upper = int($numhits/$maxhits) + 1);
|
||||
# Finally, adjust those page numbers if we are near an endpoint.
|
||||
(7 - $nh >= 0) and ($upper = $upper + (8 - $nh));
|
||||
($nh > ($numhits/$maxhits - 7)) and ($lower = $lower - ($nh - int($numhits/$maxhits - 7) - 1));
|
||||
$url = "";
|
||||
# Then let's go through the pages and build the HTML.
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=1">[<<]</a> ~);
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=$prev_hit">[<]</a> ~);
|
||||
for ($i = 1; $i <= int($numhits/$maxhits) + 1; $i++) {
|
||||
if ($i < $lower) { $url .= " ... "; $i = ($lower-1); next; }
|
||||
if ($i > $upper) { $url .= " ... "; last; }
|
||||
($i == $nh) ?
|
||||
($url .= qq~$i ~) :
|
||||
($url .= qq~<a href="$script&nh=$i">$i</a> ~);
|
||||
if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; }
|
||||
}
|
||||
$url .= qq~<a href="$script;nh=$next_hit">[>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
$url .= qq~<a href="$script;nh=$max_page">[>>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Public wrapper to private method.
|
||||
#
|
||||
return _escape ($_[1]);
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# SEARCH WIDGETS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _mk_search_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Create the search options boxes based on type.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator _mk_search_opts");
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_search_opts");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_search_opts");
|
||||
my $val = '';
|
||||
CASE: {
|
||||
exists $opts->{value} and $val = $opts->{value}, last CASE;
|
||||
exists $self->{input}->{"$name-opt"} and $val = $self->{input}->{"$name-opt"}, last CASE;
|
||||
$opts->{pk} and $val = '=', last CASE;
|
||||
$opts->{unique} and $val = '=', last CASE;
|
||||
}
|
||||
$val = '>' if $val eq '>';
|
||||
$val = '<' if $val eq '<';
|
||||
|
||||
my $type = $def->{type};
|
||||
|
||||
my ($hash, $so);
|
||||
CASE: {
|
||||
($type =~ /INT|FLOAT|DOUBLE|DECIMAL/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than'},
|
||||
$so = [ 'LIKE', '=', '<>', '>', '<' ], last CASE;
|
||||
($type =~ /CHAR/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', },
|
||||
$so = [ 'LIKE', '=', '<>' ], last CASE;
|
||||
($type =~ /DATE|TIME/i)
|
||||
and $hash = { '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than'},
|
||||
$so = [ '=', '>', '<', '<>' ], last CASE;
|
||||
}
|
||||
|
||||
if ($hash) {
|
||||
return $self->select( { name => "$name-opt", values => $hash, sort_order => $so, value => $val, def => $def, blank => 0 } );
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# UTILS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Escape HTML quotes and < and >.
|
||||
#
|
||||
my $t = shift || '';
|
||||
$$t =~ s/&/&/g;
|
||||
$$t =~ s/"/"/g;
|
||||
$$t =~ s/</</g;
|
||||
$$t =~ s/>/>/g;
|
||||
}
|
||||
|
||||
sub _get_time {
|
||||
# ---------------------------------------------------------------
|
||||
# Return current time for timestamp field.
|
||||
#
|
||||
my ($self, $col) = @_;
|
||||
my ($sec,$min,$hr,$day,$mon,$yr) = (localtime())[0..5];
|
||||
my $val;
|
||||
$mon++; $yr = $yr + 1900;
|
||||
($sec < 10) and ($sec = "0$sec"); ($min < 10) and ($min = "0$min"); ($hr < 10) and ($hr = "0$hr");
|
||||
($day < 10) and ($day = "0$day"); ($mon < 10) and ($mon = "0$mon");
|
||||
CASE: {
|
||||
($col->{type} =~ /DATETIME|TIMESTAMP/) and ($val = "$yr-$mon-$day $hr:$min:$sec"), last CASE;
|
||||
($col->{type} =~ /DATE/) and ($val = "$yr-$mon-$day"), last CASE;
|
||||
($col->{type} =~ /YEAR/) and ($val = "$yr"), last CASE;
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _get_multi {
|
||||
my ($self, $opts) = @_;
|
||||
my ($names, $values) = ([], []);
|
||||
$opts->{def} ||= $self->{db}->{schema}->{cols}->{$opts->{name}};
|
||||
|
||||
# Deep copy $opts->{def} => $def
|
||||
my $def = {};
|
||||
while (my ($k, $v) = each %{$opts->{def}}) {
|
||||
if (! ref $v) {
|
||||
$def->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$def->{$k} = {};
|
||||
foreach my $k1 (keys %{$opts->{def}->{$k}}) { $def->{$k}->{$k1} = $opts->{def}->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$def->{$k} = [];
|
||||
foreach my $v1 (@{$opts->{def}->{$k}}) { push @{$def->{$k}}, $v1; }
|
||||
}
|
||||
else { $def->{$k} = $v; }
|
||||
}
|
||||
if (
|
||||
(exists $def->{form_names}) and
|
||||
(ref ($def->{form_names}) eq 'ARRAY') and
|
||||
(@{$def->{form_names}})
|
||||
)
|
||||
{
|
||||
$names = $def->{form_names};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$names = $def->{values};
|
||||
}
|
||||
|
||||
# Get the values.
|
||||
if (
|
||||
(exists $def->{form_values}) and
|
||||
(ref ($def->{form_values}) eq 'ARRAY') and
|
||||
(@{$def->{form_values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{form_values};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{values};
|
||||
}
|
||||
|
||||
# Can pass in a hash here.
|
||||
if (
|
||||
(exists $opts->{values}) and
|
||||
(ref ($opts->{values}) eq 'HASH') and
|
||||
(keys %{$opts->{values}})
|
||||
)
|
||||
{
|
||||
@{$names} = keys %{$opts->{values}};
|
||||
@{$values} = values %{$opts->{values}};
|
||||
}
|
||||
|
||||
@{$names} or @{$names} = @{$values};
|
||||
@{$values} or @{$values} = @{$names};
|
||||
|
||||
return ($names, $values);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
278
site/glist/lib/GT/SQL/Display/HTML/Relation.pm
Normal file
278
site/glist/lib/GT/SQL/Display/HTML/Relation.pm
Normal file
@ -0,0 +1,278 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Relation.pm,v 1.18 2004/08/28 03:53:45 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML::Relation;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
|
||||
use GT::SQL::Display::HTML;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
code => {},
|
||||
mode => '',
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0,
|
||||
};
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opts = shift;
|
||||
$self->reset_opts;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display ($opts || ());
|
||||
}
|
||||
|
||||
sub _display {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{pk} = [$self->{db}->pk] unless $self->{pk};
|
||||
$self->{cols} = $self->{db}->ordered_columns;
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}}) if ($self->{pk});
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @ntables = values %{$self->{db}->{tables}};
|
||||
my (@tmp, @tables);
|
||||
for my $t (@ntables) {
|
||||
my @cols = $t->ordered_columns;
|
||||
my %fk = $t->fk;
|
||||
my %cols = $t->cols;
|
||||
my $name = $t->name;
|
||||
my $found = 0;
|
||||
COL: foreach my $col_name (@cols) {
|
||||
if (exists $self->{values}->{$col_name}) {
|
||||
$self->{values}->{$name . '.' . $col_name} = delete $self->{values}->{$col_name};
|
||||
}
|
||||
$self->{cols}->{$name . '.' . $col_name} = $cols{$col_name};
|
||||
FK: for (keys %fk) {
|
||||
if (exists $self->{db}->{tables}->{$_}) {
|
||||
if (exists $fk{$_}->{$col_name}) {
|
||||
$found = 1;
|
||||
last FK;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$found ? (push (@tmp, $t)) : (@tables = ($t));
|
||||
}
|
||||
push @tables, @tmp;
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Set the table widths depending on if we need a third column.
|
||||
my ($cwidth, $vwidth) = ('30%', '70%');
|
||||
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
|
||||
|
||||
for my $table (@tables) {
|
||||
$out .= $self->mk_table (
|
||||
table => $table,
|
||||
values => $values,
|
||||
cwidth => $cwidth,
|
||||
vwidth => $vwidth
|
||||
);
|
||||
}
|
||||
$out .= '<br>';
|
||||
|
||||
foreach (@{$self->{hide}}) {
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
|
||||
my $val = $values->{$_};
|
||||
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
|
||||
$val ||= $self->_get_time ($self->{cols}->{$_});
|
||||
}
|
||||
defined $val or ($val = '');
|
||||
GT::SQL::Display::HTML::_escape(\$val);
|
||||
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
|
||||
}
|
||||
$self->{extra_table} and ($out .= "</td></tr></table>\n");
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub mk_table {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
|
||||
my $out = '';
|
||||
$self->{extra_table} and ($out .= "<p><table border=1 cellpadding=0 cellspacing=0><tr><td>");
|
||||
my $cols = $opt{table}->cols;
|
||||
my $name = $opt{table}->name;
|
||||
|
||||
$out .= qq(
|
||||
<table $self->{table}>
|
||||
<tr><td colspan=3 bgcolor=navy>
|
||||
<FONT FACE="MS Sans Serif, arial,helvetica" size=1 COLOR="#FFFFFF">$name</font>
|
||||
</td></tr>
|
||||
);
|
||||
my @cols = $opt{table}->ordered_columns;
|
||||
my %fk = $opt{table}->fk;
|
||||
|
||||
COL: foreach my $col_name (@cols) {
|
||||
$out .= $self->mk_row (%opt, col_name => $col_name, fk => \%fk);
|
||||
}
|
||||
$out .= "</table>\n";
|
||||
$out .= "</table></p>\n" if $self->{extra_table};
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub mk_row {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
my $out = '';
|
||||
for (keys %{$opt{fk}}) {
|
||||
if (exists $self->{db}->{tables}->{$_}) {
|
||||
(exists $opt{fk}->{$_}->{$opt{col_name}}) and return '';
|
||||
}
|
||||
}
|
||||
my $col = $opt{table}->name . '.' . $opt{col_name};
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $opt{values});
|
||||
return '';
|
||||
}
|
||||
return '' if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = exists ($self->{cols}->{$col}->{form_display}) ? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $opt{values}->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and return '';
|
||||
$out .= "<tr $self->{tr}><td $self->{td} width='$opt{cwidth}'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$opt{vwidth}'><font $self->{val_font}>";
|
||||
|
||||
# Get the column display subroutine
|
||||
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }, $opt{values}, $self );
|
||||
|
||||
$out .= "</font></td>";
|
||||
|
||||
# Display any search options if requested.
|
||||
if ($self->{search_opts}) {
|
||||
my $is_pk = 0;
|
||||
for (@{$self->{pk}}) {
|
||||
$is_pk = 1, last if ($_ eq $col);
|
||||
}
|
||||
|
||||
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
|
||||
$out .= $self->_mk_search_opts({
|
||||
name => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
pk => $is_pk
|
||||
}) || ' ';
|
||||
$out .= "</font></td>";
|
||||
}
|
||||
$out .= "\n";
|
||||
return $out;
|
||||
|
||||
}
|
||||
|
||||
sub _get_defaults {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns default values for fields. Bases it on what's passed in,
|
||||
# cgi input, def file defaults, otherwise blank.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my @ntables = values %{$self->{db}->{tables}};
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $c = $self->{cols};
|
||||
my $values = {};
|
||||
foreach my $col (@cols) {
|
||||
my $value = '';
|
||||
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
||||
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
||||
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
||||
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
(defined $c->{$col}->{default} and $c->{$col}->{default} =~ /0000/)
|
||||
? ($value = $self->_get_time($c->{$col}))
|
||||
: ($value = $c->{$col}->{default});
|
||||
}
|
||||
else {
|
||||
$value = $c->{$col}->{default};
|
||||
}
|
||||
}
|
||||
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
$value = $self->_get_time($c->{$col});
|
||||
}
|
||||
$values->{$col} = $value;
|
||||
}
|
||||
return $values;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields.
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
|
||||
=cut
|
||||
289
site/glist/lib/GT/SQL/Display/HTML/Table.pm
Normal file
289
site/glist/lib/GT/SQL/Display/HTML/Table.pm
Normal file
@ -0,0 +1,289 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Table.pm,v 1.26 2004/10/01 21:52:12 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML::Table;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
|
||||
use GT::SQL::Display::HTML;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
code => {},
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
mode => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0
|
||||
};
|
||||
|
||||
|
||||
sub display_row {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record row as html.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display_row ($opts || ());
|
||||
}
|
||||
|
||||
sub display_row_cols {
|
||||
# ---------------------------------------------------------------
|
||||
# returns the <td></td> for each of the title names for columns
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $script = GT::CGI->url();
|
||||
$script =~ s/[\&;]?sb=([^&;]*)//g;
|
||||
my $sb = $1;
|
||||
$script =~ s/[\&;]?so=(ASC|DESC)//g;
|
||||
my $so = $1;
|
||||
|
||||
foreach my $col (@cols) {
|
||||
$out .= qq!\n\t<td><font $self->{col_font}><b>!;
|
||||
$out .= qq!<a href="$script&sb=$col&so=! . ( ( ( $col eq $sb ) and $so eq 'ASC' ) ? 'DESC' : 'ASC' ) . qq!">!;
|
||||
$out .= exists $self->{db}->{schema}->{cols}->{$col}->{form_display} ? $self->{db}->{schema}->{cols}->{$col}->{form_display} : $col;
|
||||
$out .= ( ( $col eq $sb ) ? ( ($so eq 'ASC') ? " ^" : " v" ) : '' ) . "</a>";
|
||||
$out .= qq!</b></font></td>\n!;
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub _display_row {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
foreach my $col (@cols) {
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values);
|
||||
next;
|
||||
}
|
||||
next if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = exists $self->{cols}->{$col}->{form_display} ? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $values->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
|
||||
|
||||
$out .= qq!\n\t<td valign=texttop><font $self->{col_font}>!;
|
||||
|
||||
# Get the column display subroutine
|
||||
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value });
|
||||
|
||||
$out .= qq!</font></td>\n!;
|
||||
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display ($opts || ());
|
||||
}
|
||||
|
||||
sub _display {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash, primary keys, and unique columns
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Opening table.
|
||||
$self->{extra_table} and ($out .= "<table border=1 cellpadding=0 cellspacing=0><tr><td>");
|
||||
$out .= "<table $self->{table}>";
|
||||
|
||||
# Set the table widths depending on if we need a third column.
|
||||
my ($cwidth, $vwidth);
|
||||
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
|
||||
else { $cwidth = "30%"; $vwidth = "70%" }
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
foreach my $col (@cols) {
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values);
|
||||
next;
|
||||
}
|
||||
next if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = (exists $self->{cols}->{$col}->{form_display} and length $self->{cols}->{$col}->{form_display})
|
||||
? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $values->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
|
||||
$out .= "<tr $self->{tr}><td $self->{td} width='$cwidth'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$vwidth'><font $self->{val_font}>";
|
||||
|
||||
# Get the column display subroutine
|
||||
my $o = $self->$disp(
|
||||
{
|
||||
name => (defined $field_name ? $field_name : ''),
|
||||
def => $self->{cols}->{$col},
|
||||
value => (defined $value ? $value : '')
|
||||
},
|
||||
($values || {}),
|
||||
$self
|
||||
);
|
||||
$out .= $o if defined $o;
|
||||
$out .= "</font></td>";
|
||||
|
||||
# Display any search options if requested.
|
||||
if ($self->{search_opts}) {
|
||||
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
|
||||
$out .= $self->_mk_search_opts({
|
||||
name => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
pk => $self->{db}->_is_pk($col),
|
||||
unique => $self->{db}->_is_unique($col)
|
||||
}) || ' ';
|
||||
$out .= "</font></td>";
|
||||
}
|
||||
$out .= "\n";
|
||||
}
|
||||
$out .= "</table>\n";
|
||||
|
||||
my %seen;
|
||||
foreach (@{$self->{hide}}) {
|
||||
next if $seen{$_}++;
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
|
||||
my $val = $values->{$_};
|
||||
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
|
||||
$val ||= $self->_get_time ($self->{cols}->{$_});
|
||||
}
|
||||
defined $val or ($val = '');
|
||||
GT::SQL::Display::HTML::_escape(\$val);
|
||||
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
|
||||
}
|
||||
$self->{extra_table} and ($out .= "</td></tr></table>\n");
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields.
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
|
||||
=cut
|
||||
897
site/glist/lib/GT/SQL/Driver.pm
Normal file
897
site/glist/lib/GT/SQL/Driver.pm
Normal file
@ -0,0 +1,897 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver
|
||||
# CVS Info :
|
||||
# $Id: Driver.pm,v 2.5 2005/02/25 03:37:29 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Overview: This implements a driver class.
|
||||
#
|
||||
|
||||
package GT::SQL::Driver;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::SQL::Table;
|
||||
use GT::AutoLoader;
|
||||
use GT::SQL::Driver::Types;
|
||||
use GT::SQL::Driver::debug;
|
||||
use Exporter();
|
||||
require GT::SQL::Driver::sth;
|
||||
use vars qw/%CONN @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS %QUERY_MAP/;
|
||||
|
||||
use constant PROTOCOL => 2;
|
||||
|
||||
$ATTRIBS = {
|
||||
name => '',
|
||||
schema => '',
|
||||
dbh => '',
|
||||
connect => {}
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 2.5 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::debug/;
|
||||
|
||||
%QUERY_MAP = (
|
||||
# QUERY => METHOD (will be prefixed with '_prepare_' or '_execute_')
|
||||
CREATE => 'create',
|
||||
INSERT => 'insert',
|
||||
ALTER => 'alter',
|
||||
SELECT => 'select',
|
||||
UPDATE => 'update',
|
||||
DROP => 'drop',
|
||||
DELETE => 'delete',
|
||||
DESCRIBE => 'describe',
|
||||
'SHOW TABLES' => 'show_tables',
|
||||
'SHOW INDEX' => 'show_index'
|
||||
);
|
||||
|
||||
$DBI::errstr if 0;
|
||||
|
||||
sub load_driver {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Loads a sub-driver (i.e. GT::SQL::Driver::MYSQL, GT::SQL::Driver::PG, etc.),
|
||||
# and creates and returns a new driver object. The first argument should be
|
||||
# the name of the driver (e.g. 'PG'), and the remaining arguments are passed to
|
||||
# new() - which could well be handled by the driver.
|
||||
#
|
||||
my ($class, $driver, @opts) = @_;
|
||||
|
||||
# Old GT::SQL versions had an 'ODBC' driver that wasn't an ODBC driver, but an
|
||||
# MSSQL driver that used ODBC.
|
||||
$driver = 'MSSQL' if $driver eq 'ODBC';
|
||||
|
||||
my $pkg = "GT::SQL::Driver::$driver";
|
||||
my $lib_path = $INC{'GT/SQL/Driver.pm'};
|
||||
$lib_path =~ s|GT/SQL/Driver\.pm$||;
|
||||
{
|
||||
# Ensure that the driver is loaded from the same location as GT/SQL/Driver.pm
|
||||
local @INC = ($lib_path, @INC);
|
||||
require "GT/SQL/Driver/$driver.pm";
|
||||
}
|
||||
|
||||
my $protocol = $pkg->protocol_version;
|
||||
return $class->fatal(DRIVERPROTOCOL => PROTOCOL, $protocol) if $protocol != PROTOCOL;
|
||||
|
||||
return $pkg->new(@opts);
|
||||
}
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Generic new() method for drivers to inherit; load_driver() should be used
|
||||
# instead to get a driver object.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); invalid parameter: '@_'");
|
||||
|
||||
# Otherwise we need to make sure we have a schema.
|
||||
$opts->{schema} and ref $opts->{schema} or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); must specify schema and name");
|
||||
|
||||
$self->{name} = $opts->{name};
|
||||
$self->{schema} = $opts->{schema};
|
||||
$self->{connect} = $opts->{connect};
|
||||
$self->{_debug} = $opts->{debug} || $DEBUG;
|
||||
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
|
||||
$self->{dbh} = undef;
|
||||
$self->{hints} = { $self->hints };
|
||||
$self->debug("New driver object loaded from table: $self->{name}.") if ($self->{_debug} > 2);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# This method is designed to be subclassed to provide "hints" for simple, small
|
||||
# differences between drivers, which simplifies the code over using a subclass.
|
||||
# It returns a hash of hints, with values of "1" unless otherwise indicated.
|
||||
# Currently supported hints are:
|
||||
# case_map # Corrects ->fetchrow_hashref column case when the database doesn't
|
||||
# prefix_indexes # Indexes will be prefixed with the table name (including the table's prefix)
|
||||
# fix_index_dbprefix # Look for erroneous (db_prefix)(index) when dropping indexes
|
||||
# now # Specifies an SQL value to use instead of NOW() (for 'time_check' columns, among other things)
|
||||
# bind # An array ref of: [\%BIND_HASH, ('COLUMNTYPE' => $bind_type, 'TYPE2' => $bind_type2, ...)] for drivers that need special placeholder binding for certain column types
|
||||
# ai # Contains a string to use for an AI column; or a code reference that is passed ($table, $column) and returns the string, or an array reference of queries to run to create the ai sequence after the column/table has been created
|
||||
# drop_pk_constraint # use ALTER TABLE ... DROP CONSTRAINT pkeyname to drop a primary key
|
||||
sub hints { () }
|
||||
# Removing the () breaks under 5.00404, as it will return @_ in list context
|
||||
|
||||
$COMPILE{protocol_version} = __LINE__ . <<'END_OF_SUB';
|
||||
sub protocol_version {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This checks the GT::SQL::Driver protocol, and dies if the versions aren't
|
||||
# equal. The protocol version only changes for major driver changes such as
|
||||
# the v2.000 version of this module, which had the drivers do their own queries
|
||||
# (as opposed to the previous hack of having drivers trying to return alternate
|
||||
# versions of MySQL's queries). All protocol v2 and above drivers are required
|
||||
# to override this - any driver that does not is, by definition, a protocol v1
|
||||
# driver.
|
||||
#
|
||||
# The current protocol version is defined by the PROTOCOL constant - but
|
||||
# drivers that haven't overridden protocol_version() are, by definition, v1.
|
||||
#
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub available_drivers {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of available GT::SQL::Driver::* drivers
|
||||
#
|
||||
my $driver_path = $INC{'GT/SQL/Driver.pm'};
|
||||
$driver_path =~ s/\.pm$//;
|
||||
my $dh = \do { local *DH; *DH };
|
||||
my @drivers;
|
||||
opendir $dh, $driver_path or return ();
|
||||
while (defined(my $driver = readdir $dh)) {
|
||||
# By convention, only all-uppercase modules are accepted as GT::SQL drivers
|
||||
next unless $driver =~ /^([A-Z_][A-Z0-9_]*)\.pm$/;
|
||||
push @drivers, $1;
|
||||
}
|
||||
@drivers;
|
||||
}
|
||||
|
||||
sub connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the current database handle.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{dbh} and return $self->{dbh};
|
||||
|
||||
eval { require DBI };
|
||||
if ($@) {
|
||||
return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
|
||||
}
|
||||
|
||||
# Make sure we have a database, otherwise probably an error.
|
||||
exists $self->{connect}->{database} or return $self->fatal(CANTCONNECT => "No connection string passed to tbl->connect, make sure your table object got a connection hash.");
|
||||
keys %{$self->{schema}} or return $self->fatal(CANTCONNECT => "Unable to connect to database without a valid schema.");
|
||||
|
||||
my $dsn = $self->dsn($self->{connect});
|
||||
my $conn_key = "$dsn\0$self->{connect}->{login}\0$self->{connect}->{password}";
|
||||
if (defined $CONN{$conn_key}) {
|
||||
$self->{dbh} = $CONN{$conn_key};
|
||||
$self->debug("Using stored connection: $dsn") if ($self->{_debug} > 1);
|
||||
return $CONN{$conn_key};
|
||||
}
|
||||
|
||||
# Connect to the database.
|
||||
$self->debug("Connecting to database with: '$dsn', '$self->{connect}->{login}', '******'") if ($self->{_debug} > 1);
|
||||
my $res = eval {
|
||||
$CONN{$conn_key} = DBI->connect($dsn, $self->{connect}->{login}, $self->{connect}->{password}, { RaiseError => $self->{connect}->{RaiseError}, PrintError => $self->{connect}->{PrintError}, AutoCommit => 1 })
|
||||
or die "$DBI::errstr\n";
|
||||
1;
|
||||
};
|
||||
$res or return $self->warn(CANTCONNECT => "$@");
|
||||
|
||||
$self->{dbh} = $CONN{$conn_key};
|
||||
$self->debug("Connected successfully to database.") if $self->{_debug} > 1;
|
||||
|
||||
return $self->{dbh};
|
||||
}
|
||||
|
||||
$COMPILE{dsn} = __LINE__ . <<'END_OF_SUB';
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the data source name used by DBI to connect to the database.
|
||||
# Since this is database-dependant, this is just a stub.
|
||||
#
|
||||
require Carp;
|
||||
Carp::croak("Driver has no dsn()");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prepare_raw} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prepare_raw {
|
||||
# ---------------------------------------------------------------
|
||||
# Returns a raw sth object.
|
||||
# WARNING: MAKE SURE YOUR SQL IS PORTABLE AS NO ALTERATIONS WILL
|
||||
# BE MADE! ALSO YOU MUST MANUALLY CALL ->finish ON THESE!
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$self->debug("Preparing RAW query: $query") if $self->{_debug} > 1;
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
|
||||
$self->debug("RAW STH is prepared: $query") if $self->{_debug} > 1;
|
||||
return $sth;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prepare {
|
||||
# ---------------------------------------------------------------
|
||||
# We can override whatever type of queries we need to alter by replacing
|
||||
# the _prepare_* functions.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if (! defined $query) {
|
||||
return $self->warn(CANTPREPARE => "", "Empty Query");
|
||||
}
|
||||
|
||||
# For any drivers that need hacked-in limit support (currently MS SQL and Oracle):
|
||||
delete @$self{qw/_limit _lim_offset _lim_rows/};
|
||||
|
||||
if (my $now = $self->{hints}->{now}) {
|
||||
$query =~ s/\bNOW\(\)/$now/g;
|
||||
}
|
||||
|
||||
if ($query =~ /^\s*SHOW\s+TABLES\s*(?:;\s*)?$/i) {
|
||||
$self->{do} = 'SHOW TABLES';
|
||||
}
|
||||
elsif ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+\w+\s*(?:;\s*)?$/i) {
|
||||
# See 'Driver-specific notes' below
|
||||
$self->{do} = 'SHOW INDEX';
|
||||
}
|
||||
else {
|
||||
$self->{do} = uc +($query =~ /(\w+)/)[0];
|
||||
}
|
||||
if (my $meth = $QUERY_MAP{$self->{do}}) {
|
||||
$meth = "_prepare_$meth";
|
||||
$query = $self->$meth($query) or return;
|
||||
}
|
||||
|
||||
$self->{query} = $query;
|
||||
$self->debug("Preparing query: $query") if $self->{_debug} > 1;
|
||||
|
||||
$self->{sth} = $self->{dbh}->prepare($query)
|
||||
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
|
||||
|
||||
my $pkg = ref($self) . '::sth';
|
||||
$self->debug("CREATING $pkg OBJECT") if $self->{_debug} > 2;
|
||||
return $pkg->new($self);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Define one generic prepare, and alias all the specific _prepare_* functions to it
|
||||
sub _generic_prepare { $_[1] }
|
||||
for (*_prepare_create, *_prepare_insert, *_prepare_alter, *_prepare_select, *_prepare_update, *_prepare_drop, *_prepare_delete, *_prepare_describe) {
|
||||
$_ = \&_generic_prepare;
|
||||
}
|
||||
# Driver-specific notes:
|
||||
# 'SHOW TABLES'
|
||||
# The driver should return single-column rows of non-system tables in the
|
||||
# database. The name of the column is not important, and users of SHOW TABLE
|
||||
# should not depend on it (i.e. do not use ->fetchrow_hashref)
|
||||
*_prepare_show_tables = \&_generic_prepare;
|
||||
# 'SHOW INDEX FROM table'
|
||||
# Drivers should return one row per column per index, having at least the keys:
|
||||
# - index_name: the name of the index
|
||||
# - index_column: the name of the column
|
||||
# - index_unique: 1 if the index is unique, 0 otherwise
|
||||
# - index_primary: 1 if the column is a primary key, 0 otherwise
|
||||
#
|
||||
# The rows must be grouped by index, and ordered by the position of the column
|
||||
# within said groupings.
|
||||
#
|
||||
# So, for a unique index named 'unique1' on columns 'col1', 'col2', 'col3', and
|
||||
# a normal index named 'index1' on 'col3', 'col4', and a primary key on
|
||||
# 'colpk', you should get (at a minimum; extra columns are permitted):
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index_name | index_column | index_unique | index_primary |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | unique1 | col1 | 1 | 0 |
|
||||
# | unique1 | col2 | 1 | 0 |
|
||||
# | unique1 | col3 | 1 | 0 |
|
||||
# | index1 | col3 | 0 | 0 |
|
||||
# | index1 | col4 | 0 | 0 |
|
||||
# | PRIMARY | colpk | 1 | 1 |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# 'PRIMARY' above should be changed by drivers whose databases have named
|
||||
# primary keys, otherwise using 'PRIMARY' for the primary key is recommended.
|
||||
#
|
||||
# Any other information may be returned; users of this query mapping should
|
||||
# always use ->fetchrow_hashref, and access the above four keys for
|
||||
# portability.
|
||||
#
|
||||
# Note that index_primary results may overlap other indexes for some databases
|
||||
# - Oracle, in particular, will bind a primary key onto an existing index if
|
||||
# possible. In such a case, you'll get the index indicated normally, but some
|
||||
# of the columns may make up the primary key. For example, the following
|
||||
# result would indicate that there is one index on col1, col2, col3, and that
|
||||
# there is a primary key made up of (col1, col2):
|
||||
#
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index_name | index_column | index_unique | index_primary |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index1 | col1 | 0 | 1 |
|
||||
# | index1 | col2 | 0 | 1 |
|
||||
# | index1 | col3 | 0 | 0 |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
#
|
||||
# Currently, results such as the above are known to occur in Oracle databases
|
||||
# where a primary key was added to an already-indexed column after creating the
|
||||
# table - other databases give primary keys an independant index.
|
||||
#
|
||||
# Although _prepare_show_index is defined here, no drivers actually satisfy the
|
||||
# above without some query result remapping, and as such all currently override
|
||||
# either this or _execute_show_index.
|
||||
*_prepare_show_index = \&_generic_prepare;
|
||||
|
||||
$COMPILE{extract_index_name} = __LINE__ . <<'END_OF_SUB';
|
||||
sub extract_index_name {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes an table name and database index name (which could be prefixed, if the
|
||||
# database uses prefixes) and returns the GT::SQL index name (i.e. without
|
||||
# prefix).
|
||||
my ($self, $table, $index) = @_;
|
||||
if ($self->{hints}->{prefix_indexes}) {
|
||||
$index =~ s/^\Q$table\E(?=.)//i;
|
||||
}
|
||||
$index;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub disconnect {
|
||||
# -------------------------------------------------------------------
|
||||
# Disconnect from the database.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{dbh} and $self->{dbh}->disconnect;
|
||||
}
|
||||
|
||||
sub reset_env {
|
||||
# -------------------------------------------------------------------
|
||||
# Remove all database connections that aren't still alive
|
||||
#
|
||||
@GT::SQL::Driver::debug::QUERY_STACK = ();
|
||||
for my $dsn (keys %CONN) {
|
||||
next if ($CONN{$dsn} and $CONN{$dsn}->ping);
|
||||
$CONN{$dsn}->disconnect if ($CONN{$dsn});
|
||||
delete $CONN{$dsn};
|
||||
}
|
||||
}
|
||||
|
||||
sub do {
|
||||
# -------------------------------------------------------------------
|
||||
# Do a query.
|
||||
#
|
||||
my $self = shift;
|
||||
($self->prepare(@_) or return)->execute;
|
||||
}
|
||||
|
||||
$COMPILE{do_raw_transaction} = __LINE__ . <<'END_OF_SUB';
|
||||
sub do_raw_transaction {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Do a series of queries as a single transaction - note that this is only
|
||||
# supported under DBI >= 1.20; older versions of DBI result in the queries
|
||||
# being performed without a transaction.
|
||||
# This subroutine should be passed a list of queries; the queries will be run
|
||||
# in order. Each query may optionally be an array reference where the first
|
||||
# element is the query, and remaining elements are placeholders to use when
|
||||
# executing the query. Furthermore, you may pass a reference to the string
|
||||
# or array reference to specify a non-critical query.
|
||||
#
|
||||
# For example:
|
||||
# $self->do_raw_transaction(
|
||||
# "QUERY1",
|
||||
# \["QUERY2 ?", $value],
|
||||
# \"QUERY3",
|
||||
# ["QUERY4 ?, ?", $value1, $value2]
|
||||
# );
|
||||
#
|
||||
# This will attempt to run the 4 queries, and will abort if query 1 or 4 do not
|
||||
# succeed.
|
||||
#
|
||||
# Also note that this is ONLY meant to be used by individual drivers as it
|
||||
# assumes the queries passed in are ready to run without any rewriting. As
|
||||
# such, any use outside of individual drivers should be considered an error.
|
||||
#
|
||||
# Returns '1' on success, undef on failure of any query (excepting non-critical
|
||||
# queries, see above).
|
||||
#
|
||||
my ($self, @queries) = @_;
|
||||
|
||||
my $transaction = $DBI::VERSION >= 1.20;
|
||||
$self->{dbh}->begin_work if $transaction;
|
||||
|
||||
$self->debug("Begin query transaction") if $self->{_debug};
|
||||
$self->debug("Transaction not possible; DBI version < 1.20") if $self->{_debug} and not $transaction;
|
||||
|
||||
my $time;
|
||||
$time = Time::HiRes::time() if $self->{_debug} and exists $INC{"Time/HiRes.pm"};
|
||||
for (@queries) {
|
||||
my $critical = not(ref eq 'SCALAR' or ref eq 'REF');
|
||||
my $q = $critical ? $_ : $$_;
|
||||
my ($query, @ph) = ref $q ? @$q : $q;
|
||||
if ($self->{_debug}) {
|
||||
my $debugquery = GT::SQL::Driver::debug->replace_placeholders($query, @ph);
|
||||
$self->debug("Executing query $debugquery");
|
||||
}
|
||||
my $did = $self->{dbh}->do($query, undef, @ph);
|
||||
if (!$did and $critical) {
|
||||
$self->warn(CANTEXECUTE => $query => $DBI::errstr);
|
||||
$self->debug("Critical query failed, transaction aborted; performing transaction rollback")
|
||||
if $self->{_debug} and $transaction;
|
||||
$self->{dbh}->rollback if $transaction;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("Transaction complete; committing") if $self->{_debug};
|
||||
$self->{dbh}->commit if $transaction;
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Transaction execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------
|
||||
# This subroutines quotes (or not) a value.
|
||||
#
|
||||
my $val = pop;
|
||||
return 'NULL' if not defined $val;
|
||||
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
|
||||
(values %CONN)[0]->quote($val);
|
||||
}
|
||||
|
||||
$COMPILE{create_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates a table.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->connect or return;
|
||||
|
||||
my $table = $self->{name};
|
||||
|
||||
# Figure out the order of the create, and then build the create statement.
|
||||
my %pos = map { $_ => $self->{schema}->{cols}->{$_}->{pos} } keys %{$self->{schema}->{cols}};
|
||||
my (@field_defs, $ai_queries);
|
||||
for my $field (sort { $pos{$a} <=> $pos{$b} } keys %{$self->{schema}->{cols}}) {
|
||||
my %field_def = map { defined $self->{schema}->{cols}->{$field}->{$_} ? ($_ => $self->{schema}->{cols}->{$field}->{$_}) : () } keys %{$self->{schema}->{cols}->{$field}};
|
||||
my $is_ai = $self->{schema}->{ai} && $field eq $self->{schema}->{ai};
|
||||
delete $field_def{default} if $is_ai;
|
||||
my $def = $field . ' ' . ($self->column_sql(\%field_def) or return);
|
||||
if ($is_ai) {
|
||||
my $ai = $self->{hints}->{ai} || 'AUTO_INCREMENT';
|
||||
$ai = $ai->($table, $field) if ref $ai eq 'CODE';
|
||||
if (ref $ai eq 'ARRAY') {
|
||||
$ai_queries = $ai;
|
||||
}
|
||||
else {
|
||||
$def .= " $ai";
|
||||
}
|
||||
}
|
||||
push @field_defs, $def;
|
||||
}
|
||||
|
||||
# Add the primary key.
|
||||
if (@{$self->{schema}->{pk}}) {
|
||||
push @field_defs, "PRIMARY KEY (" . join(",", @{$self->{schema}->{pk}}) . ")";
|
||||
}
|
||||
|
||||
# Create the table
|
||||
my $create_query = "\n\tCREATE TABLE $table (\n\t\t";
|
||||
$create_query .= join ",\n\t\t", @field_defs;
|
||||
$create_query .= "\n\t)";
|
||||
|
||||
$self->do($create_query) or return;
|
||||
|
||||
# If the database needs separate queries to set up the auto-increment, run them
|
||||
if ($ai_queries) {
|
||||
for (@$ai_queries) {
|
||||
$self->do($_);
|
||||
}
|
||||
}
|
||||
|
||||
# Create the table's indexes
|
||||
for my $type (qw/index unique/) {
|
||||
my $create_index = "create_$type";
|
||||
while (my ($index_name, $index) = each %{$self->{schema}->{$type}}) {
|
||||
$self->$create_index($table => $index_name => @$index) if @$index;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{column_sql} = __LINE__ . <<'END_OF_SUB';
|
||||
sub column_sql {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Converts a column definition into an SQL string used in the create table
|
||||
# statement, and (for some drivers) when adding a new column to a table.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
|
||||
ref $opts eq 'HASH' or return $self->fatal(BADARGS => '$obj->column_sql (HASH_REF)');
|
||||
$opts->{type} or return $self->fatal(BADARGS => 'Column definition does not have a SQL type defined');
|
||||
|
||||
my $pkg = ref($self) . '::Types';
|
||||
my $type = uc $opts->{type};
|
||||
|
||||
if ($pkg->can($type)) {
|
||||
$self->debug("Using driver specific SQL for type $opts->{type}") if $self->{_debug} > 1;
|
||||
}
|
||||
elsif (GT::SQL::Driver::Types->can($type)) {
|
||||
$pkg = 'GT::SQL::Driver::Types';
|
||||
}
|
||||
else {
|
||||
return $self->fatal(BADTYPE => $opts->{type});
|
||||
}
|
||||
$pkg->$type({%$opts});
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{insert} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This subroutine, using a couple driver hints, handles insertions for every
|
||||
# driver currently supported.
|
||||
#
|
||||
my ($self, $input) = @_;
|
||||
|
||||
my (@names, @values, @placeholders, @binds);
|
||||
my %got;
|
||||
my $ai = $self->{schema}->{ai};
|
||||
my $bind = $self->{hints}->{bind};
|
||||
my $cols = $self->{schema}->{cols};
|
||||
while (my ($col, $val) = each %$input) {
|
||||
++$got{$col};
|
||||
next if $ai and $col eq $ai and !$val;
|
||||
push @names, $col;
|
||||
my $def = $cols->{$col};
|
||||
if ($def->{time_check} and (not defined $val or $val eq '' or $val eq 'NOW()')) {
|
||||
push @values, $self->{hints}->{now} || 'NOW()';
|
||||
}
|
||||
elsif ($def->{type} =~ /DATE/ and (not defined $val or $val eq '')) {
|
||||
push @values, 'NULL';
|
||||
}
|
||||
elsif (ref $val eq 'SCALAR' or ref $val eq 'LVALUE') {
|
||||
push @values, $$val;
|
||||
}
|
||||
else {
|
||||
push @placeholders, $val;
|
||||
push @values, '?';
|
||||
if ($bind and defined $val) {
|
||||
for (my $i = 1; $i < @$bind; $i += 2) {
|
||||
if ($def->{type} =~ /$bind->[$i]/) {
|
||||
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Update any timestamp columns to current time.
|
||||
for my $col (keys %$cols) {
|
||||
next unless not $got{$col} and $cols->{$col}->{time_check};
|
||||
push @names, $col;
|
||||
push @values, $self->{hints}->{now} || 'NOW()';
|
||||
$got{$col} = 1;
|
||||
}
|
||||
|
||||
# Add an auto increment field if required
|
||||
if ($ai and not $input->{$ai}) {
|
||||
my @ai_insert = $self->ai_insert($ai);
|
||||
if (@ai_insert) {
|
||||
push @names, $ai_insert[0];
|
||||
push @values, $ai_insert[1];
|
||||
}
|
||||
}
|
||||
|
||||
# Fill in any missing defaults
|
||||
for my $col (keys %$cols) {
|
||||
next if $ai and $col eq $ai
|
||||
or $got{$col}
|
||||
or not exists $cols->{$col}->{default};
|
||||
my $val = $cols->{$col}->{default};
|
||||
push @names, $col;
|
||||
push @values, '?';
|
||||
push @placeholders, $val;
|
||||
$got{$col} = 1;
|
||||
if ($bind and defined $val) {
|
||||
my $def = $cols->{$col};
|
||||
for (my $i = 1; $i < @$bind; $i += 2) {
|
||||
if ($def->{type} =~ /$bind->[$i]/) {
|
||||
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Create the SQL and statement handle.
|
||||
my $query = "INSERT INTO $self->{name} (";
|
||||
$query .= join ',', @names;
|
||||
$query .= ") VALUES (";
|
||||
$query .= join ',', @values;
|
||||
$query .= ")";
|
||||
|
||||
$bind->[0]->{$query} = \@binds if $bind;
|
||||
|
||||
my $sth = $self->prepare($query) or return;
|
||||
$sth->execute(@placeholders) or return;
|
||||
$sth;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub ai_insert {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a column name and value to use for the AI column when inserting a
|
||||
# row. If this returns an empty list, no value will be inserted. This will
|
||||
# only be called when the table has an auto-increment column, so checking is
|
||||
# not necessary. The sole argument passed in is the name of the column.
|
||||
#
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, 'NULL';
|
||||
}
|
||||
|
||||
$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs a multiple-insertion. By default, this is simply done as multiple
|
||||
# executes on a single insertion, and as a single transaction if under
|
||||
# DBI >= 1.20.
|
||||
#
|
||||
my ($self, $cols, $args) = @_;
|
||||
$self->{dbh}->begin_work if $DBI::VERSION >= 1.20;
|
||||
my $count;
|
||||
for my $val (@$args) {
|
||||
my %set;
|
||||
for my $i (0 .. $#$cols) {
|
||||
$set{$cols->[$i]} = $val->[$i];
|
||||
}
|
||||
++$count if $self->insert(\%set);
|
||||
}
|
||||
$self->{dbh}->commit if $DBI::VERSION >= 1.20;
|
||||
$count;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub update {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $set, $where) = @_;
|
||||
|
||||
my $c = $self->{schema}->{cols};
|
||||
my %set;
|
||||
|
||||
for my $cond (@{$set->{cond}}) {
|
||||
if (ref $cond eq 'ARRAY') {
|
||||
$set{$cond->[0]}++ if exists $c->{$cond->[0]} and $c->{$cond->[0]}->{time_check};
|
||||
}
|
||||
}
|
||||
for my $col (keys %$c) {
|
||||
next unless not $set{$col} and $c->{$col}->{time_check};
|
||||
$set->add($col, '=', \($self->{hints}->{now} || 'NOW()'));
|
||||
}
|
||||
|
||||
my ($sql_set, $set_vals, $set_cols) = $set->sql(1);
|
||||
my ($sql_where, $where_vals, $where_cols) = $where->sql(1);
|
||||
my $i = 1;
|
||||
|
||||
# Set up binds, if necessary
|
||||
my @binds;
|
||||
my $bind = $self->{hints}->{bind};
|
||||
if ($bind) {
|
||||
for my $col (@$set_cols) {
|
||||
next unless exists $c->{$col};
|
||||
for (my $j = 1; $j < @$bind; $j += 2) {
|
||||
if ($c->{$col}->{type} =~ /$bind->[$j]/) {
|
||||
push @binds, [scalar $i, $col, $bind->[$j+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
|
||||
my $query = "UPDATE $self->{name} SET $sql_set";
|
||||
$query .= " WHERE $sql_where" if $sql_where;
|
||||
|
||||
$bind->[0]->{$query} = \@binds if $bind;
|
||||
|
||||
my $sth = $self->prepare($query) or return;
|
||||
$sth->execute(@$set_vals, @$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
sub delete {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $where) = @_;
|
||||
my ($sql_where, $where_vals) = $where ? $where->sql(1) : ();
|
||||
my $sql = "DELETE FROM $self->{name}";
|
||||
$sql .= " WHERE $sql_where" if $sql_where;
|
||||
|
||||
my $sth = $self->prepare($sql) or return;
|
||||
$sth->execute(@$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
sub select {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $field_arr, $where, $opts) = @_;
|
||||
|
||||
my ($fields, $opt_clause) = ('', '');
|
||||
if (ref $field_arr and @$field_arr) {
|
||||
$fields = join ",", @$field_arr;
|
||||
}
|
||||
else {
|
||||
$fields = '*';
|
||||
}
|
||||
my ($sql_where, $where_vals) = $where->sql(1);
|
||||
$sql_where and ($sql_where = " WHERE $sql_where");
|
||||
if ($opts) {
|
||||
for my $opt (@$opts) {
|
||||
next if (! defined $opt);
|
||||
$opt_clause .= " $opt";
|
||||
}
|
||||
}
|
||||
my $sql = "SELECT $fields FROM " . $self->{name};
|
||||
$sql .= $sql_where if $sql_where;
|
||||
$sql .= $opt_clause if $opt_clause;
|
||||
my $sth = $self->prepare($sql) or return;
|
||||
$sth->execute(@$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops the table passed in.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
$self->do("DROP TABLE $table");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{column_exists} = __LINE__ . <<'END_OF_SUB';
|
||||
sub column_exists {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns true or false value depending on whether the column exists in the
|
||||
# table. This defaults to a DESCRIBE of the table, then looks for the column
|
||||
# in the DESCRIBE results - but many databases probably have a much more
|
||||
# efficient alternative.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->prepare("DESCRIBE $table") or return;
|
||||
$sth->execute or return;
|
||||
my $found;
|
||||
while (my ($col) = $sth->fetchrow) {
|
||||
$found = 1, last if $col eq $column;
|
||||
}
|
||||
$found;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{add_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub add_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a column to a table.
|
||||
#
|
||||
my ($self, $table, $column, $def) = @_;
|
||||
$self->do("ALTER TABLE $table ADD $column $def");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column from a table.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
$self->do("ALTER TABLE $table DROP $column");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{alter_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub alter_column {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Changes a column. Takes table name, column name, definition for the new
|
||||
# column (string), and the old column definition (hash ref). The new column
|
||||
# definition should already be set in the table object
|
||||
# ($self->{table}->{schema}->{cols}->{$column_name}).
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
$self->do("ALTER TABLE $table CHANGE $column $column $new_def");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_index} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds an index - checks driver hints for whether or not to prefix the index
|
||||
# with the prefixed table name.
|
||||
#
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
|
||||
$self->do("CREATE INDEX $index_name ON $table (" . join(",", @index_cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_unique} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_unique {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds a unique index to a table, using the prefixed table name as a prefix.
|
||||
#
|
||||
my ($self, $table, $unique_name, @unique_cols) = @_;
|
||||
$unique_name = $table . $unique_name if $self->{hints}->{prefix_indexes};
|
||||
$self->do("CREATE UNIQUE INDEX $unique_name ON $table (" . join(",", @unique_cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Drops an index.
|
||||
#
|
||||
my ($self, $table, $index_name) = @_;
|
||||
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
|
||||
my $dropped = $self->do("DROP INDEX $index_name");
|
||||
$dropped ||= $self->do("DROP INDEX $self->{connect}->{PREFIX}$index_name") if $self->{hints}->{fix_index_dbprefix};
|
||||
$dropped;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_pk} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a primary key to a table.
|
||||
#
|
||||
my ($self, $table, @cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(",", @cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Drop a primary key.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
my $do;
|
||||
if ($self->{hints}->{drop_pk_constraint}) {
|
||||
# To drop a primary key in ODBC or Pg, you drop the primary key
|
||||
# constraint, which implicitly drops the index implicitly created by a
|
||||
# primary key.
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
|
||||
$sth->execute or return;
|
||||
|
||||
my $pk_constraint;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_primary}) {
|
||||
$pk_constraint = $index->{index_name};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$pk_constraint or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
|
||||
|
||||
$do = "ALTER TABLE $table DROP CONSTRAINT $pk_constraint";
|
||||
}
|
||||
else {
|
||||
$do = "ALTER TABLE $table DROP PRIMARY KEY";
|
||||
}
|
||||
$self->do($do);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
521
site/glist/lib/GT/SQL/Driver/MSSQL.pm
Normal file
521
site/glist/lib/GT/SQL/Driver/MSSQL.pm
Normal file
@ -0,0 +1,521 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MSSQL
|
||||
# CVS Info :
|
||||
# $Id: MSSQL.pm,v 2.6 2005/06/28 23:36:43 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: MSSQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::MSSQL;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE %BINDS/;
|
||||
use DBI qw/:sql_types/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub connect {
|
||||
# ------------------------------------------------------------------
|
||||
# Need to set some session preferences.
|
||||
#
|
||||
my $self = shift;
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# Set max read properties for DBI
|
||||
$dbh->{LongReadLen} = 1_048_576;
|
||||
|
||||
# Newer DBD::ODBC sets this to 0 which can cause cast errors
|
||||
$dbh->{odbc_default_bind_type} = SQL_VARCHAR;
|
||||
|
||||
$dbh->do("SET QUOTED_IDENTIFIER ON");
|
||||
$dbh->do("SET ANSI_NULLS ON");
|
||||
$dbh->do("SET ANSI_PADDING OFF");
|
||||
$dbh->do("SET ANSI_WARNINGS OFF");
|
||||
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Override the default create dsn, with our own. Creates DSN like:
|
||||
# DBI:ODBC:DSN
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$self->{driver} = $connect->{driver} = 'ODBC';
|
||||
|
||||
return "DBI:$connect->{driver}:$connect->{database}";
|
||||
}
|
||||
|
||||
sub hints {
|
||||
fix_index_dbprefix => 1,
|
||||
case_map => 1,
|
||||
bind => [
|
||||
\%BINDS,
|
||||
'TEXT' => DBI::SQL_LONGVARCHAR,
|
||||
'DATE|TIME' => DBI::SQL_VARCHAR
|
||||
],
|
||||
now => 'GETDATE()',
|
||||
ai => 'IDENTITY(1,1)',
|
||||
drop_pk_constraint => 1
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Track limits as ODBC has no built-in limit support; this driver hacks it in.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
my ($limit, $offset);
|
||||
|
||||
# Look for either PG or MySQL limits
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
|
||||
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
|
||||
|
||||
if ($limit) {
|
||||
$self->{_limit} = 1;
|
||||
$self->{_lim_offset} = $offset;
|
||||
my $top = $limit + $offset;
|
||||
$query =~ s/(SELECT(?:\s+DISTINCT)?)/$1 TOP $top/i;
|
||||
if (!$offset) {
|
||||
delete @$self{qw/_limit _lim_offset/};
|
||||
}
|
||||
}
|
||||
return $query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# -----------------------------------------------------------------------------
|
||||
# For compatibility with old code, 'DESCRIBE TABLE' is mapped to something that
|
||||
# looks something like a MySQL 'DESCRIBE TABLE' result.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /DESCRIBE\s+(\w+)/i) {
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
c.name AS "Field",
|
||||
CASE
|
||||
WHEN t.name LIKE '%int' THEN t.name + '(' + CAST(t.prec AS VARCHAR) + ')'
|
||||
WHEN t.name LIKE '%char' THEN t.name + '(' + CAST(c.length AS VARCHAR) + ')'
|
||||
WHEN t.name = 'decimal' THEN t.name + '(' + CAST(c.prec AS VARCHAR) + ',' + CAST(c.scale AS VARCHAR) + ')'
|
||||
WHEN t.name = 'float' THEN 'double'
|
||||
ELSE t.name
|
||||
END AS "Type",
|
||||
ISNULL(c.collation, 'binary') AS "Collation",
|
||||
CASE WHEN c.isnullable = 1 THEN 'YES' ELSE '' END AS "Null",
|
||||
(
|
||||
SELECT TOP 1
|
||||
CASE
|
||||
WHEN m.text LIKE '(''%' THEN SUBSTRING(m.text, 3, LEN(m.text) - (CASE WHEN m.text LIKE '%'')' THEN 4 ELSE 2 END))
|
||||
WHEN m.text LIKE '(%' THEN SUBSTRING(m.text, 2, LEN(m.text) - (CASE WHEN m.text LIKE '%)' THEN 2 ELSE 1 END))
|
||||
ELSE m.text
|
||||
END
|
||||
FROM syscomments m, sysobjects d
|
||||
WHERE m.id = d.id AND d.xtype = 'D' AND d.info = c.colid AND d.parent_obj = o.id
|
||||
) AS "Default",
|
||||
|
||||
CASE WHEN c.status & 0x80 = 0x80 THEN 'auto_increment' ELSE '' END AS "Extra"
|
||||
FROM
|
||||
syscolumns c, systypes t, sysobjects o
|
||||
WHERE
|
||||
c.id = o.id AND
|
||||
o.name = '$1' AND
|
||||
o.type = 'U' AND
|
||||
c.xtype = t.xtype
|
||||
ORDER BY
|
||||
c.colid
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported DESCRIBE query");
|
||||
}
|
||||
# The following could be used above for "Key" - but it really isn't that useful
|
||||
# considering there's a working SHOW INDEX:
|
||||
# (
|
||||
# SELECT
|
||||
# CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
|
||||
# FROM sysindexes i, sysindexkeys k
|
||||
# WHERE
|
||||
# i.indid = 1 AND i.id = o.id AND k.id = i.id AND k.indid = i.indid AND
|
||||
# k.colid = c.colid
|
||||
# ) AS "Key",
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT
|
||||
COUNT(*)
|
||||
FROM syscolumns c, sysobjects o
|
||||
WHERE
|
||||
c.id = o.id AND
|
||||
o.type = 'U' AND
|
||||
o.name = ? AND
|
||||
c.name = ?
|
||||
EXISTS
|
||||
$sth->execute($table, $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# MS SQL's version of MySQL's 'SHOW TABLES'; there is also 'sp_tables', but
|
||||
# that returns more information (and more tables - it includes system tables)
|
||||
# than we want.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{do} = 'SELECT';
|
||||
"SELECT name as table_name FROM sysobjects WHERE xtype = 'U'";
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# See the 'Driver-specific notes' comment in GT::SQL::Driver
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
$self->{do} = 'SELECT';
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
sysindexes.name AS index_name,
|
||||
syscolumns.name AS index_column,
|
||||
INDEXPROPERTY(sysindexes.id, sysindexes.name, 'IsUnique') AS index_unique,
|
||||
CASE
|
||||
WHEN sysindexes.indid = 1 AND (
|
||||
SELECT COUNT(*) FROM sysconstraints
|
||||
WHERE sysconstraints.id = sysobjects.id AND sysconstraints.status & 7 = 1
|
||||
) > 0 THEN 1
|
||||
ELSE 0
|
||||
END AS index_primary
|
||||
FROM
|
||||
sysindexes, sysobjects, sysindexkeys, syscolumns
|
||||
WHERE
|
||||
sysindexes.indid >= 1 AND sysindexes.indid < 255 AND
|
||||
sysindexes.id = sysobjects.id AND sysindexes.id = sysindexkeys.id AND sysindexes.id = syscolumns.id AND
|
||||
sysindexkeys.colid = syscolumns.colid AND
|
||||
sysindexes.status = 0 AND
|
||||
sysindexes.indid = sysindexkeys.indid AND
|
||||
sysobjects.xtype = 'U' AND sysobjects.name = '$1'
|
||||
ORDER BY
|
||||
sysindexkeys.indid, sysindexkeys.keyno
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query");
|
||||
}
|
||||
}
|
||||
|
||||
# MS SQL shouldn't have the AI column in the insert list
|
||||
sub ai_insert { () }
|
||||
|
||||
# Returns a list of default constraints given a table and column
|
||||
sub _defaults {
|
||||
my ($self, $table_name, $column_name) = @_;
|
||||
my $query = <<" QUERY";
|
||||
SELECT o.name
|
||||
FROM sysconstraints d, sysobjects t, syscolumns c, sysobjects o
|
||||
WHERE d.status & 5 = 5 -- status with '5' bit set indicates a default constraint
|
||||
AND d.id = t.id -- constraint table to table
|
||||
AND c.id = t.id -- column's table to table
|
||||
AND d.colid = c.colid -- constraint column to column
|
||||
AND d.constid = o.id -- constraint id to object
|
||||
AND t.name = '$table_name' -- the table we're looking for
|
||||
AND c.name = '$column_name' -- the column we're looking for
|
||||
QUERY
|
||||
my $sth = $self->{dbh}->prepare($query)
|
||||
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
|
||||
$sth->execute()
|
||||
or return $self->warn(CANTEXECUTE => $query, $DBI::errstr);
|
||||
|
||||
my @defaults;
|
||||
while (my $default = $sth->fetchrow) {
|
||||
push @defaults, $default;
|
||||
}
|
||||
return @defaults;
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Generates the SQL to drop a column.
|
||||
#
|
||||
my ($self, $table, $column, $old_col) = @_;
|
||||
|
||||
my @queries;
|
||||
|
||||
# Delete any indexes on the column, as MSSQL does not do this automatically
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table");
|
||||
$sth->execute;
|
||||
my %drop_index;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_column} eq $column) {
|
||||
$drop_index{$index->{index_name}}++;
|
||||
}
|
||||
}
|
||||
push @queries, map "DROP INDEX $table.$_", keys %drop_index;
|
||||
|
||||
for ($self->_defaults($table, $column)) {
|
||||
# Drop any default constraints
|
||||
push @queries, "ALTER TABLE $table DROP CONSTRAINT $_";
|
||||
}
|
||||
|
||||
push @queries, "ALTER TABLE $table DROP COLUMN $column";
|
||||
|
||||
$self->do_raw_transaction(@queries);
|
||||
}
|
||||
|
||||
sub alter_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Changes a column in a table.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
# make a copy so as not to clobber the original reference
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
if ($col{type} =~ /TEXT$/i) {
|
||||
# You can't alter a TEXT column in MSSQL, so we have to create an
|
||||
# entirely new column, copy the data, drop the old one, then rename the
|
||||
# new one using sp_rename.
|
||||
my $tmpcol = "tempcol__" . time . "__" . ('a' .. 'z', 'A' .. 'Z')[rand 52];
|
||||
|
||||
# We don't have to worry about dropping indexes because TEXT's can't be indexed.
|
||||
my @constraints = $self->_defaults($table, $column);
|
||||
|
||||
# Added columns must have a default, which unfortunately cannot be a column, so
|
||||
# if the definition doesn't already have a default, add a fake one. We use ''
|
||||
# for the default - though not allowed by GT::SQL, it _is_ allowed by MSSQL.
|
||||
my $no_default;
|
||||
if (not defined $col{default}) {
|
||||
$col{default} = '';
|
||||
$new_def = $self->column_sql(\%col);
|
||||
$no_default = 1;
|
||||
}
|
||||
|
||||
# This cannot be done in one single transaction as the columns won't
|
||||
# completely exist yet, as far as MSSQL is concerned.
|
||||
$self->do("ALTER TABLE $table ADD $tmpcol $new_def") or return;
|
||||
|
||||
push @constraints, $self->_defaults($table, $tmpcol) if $no_default;
|
||||
|
||||
my @q = "UPDATE $table SET $tmpcol = $column";
|
||||
push @q, map "ALTER TABLE $table DROP CONSTRAINT $_", @constraints;
|
||||
push @q, "ALTER TABLE $table DROP COLUMN $column";
|
||||
|
||||
$self->do_raw_transaction(@q) or return;
|
||||
|
||||
$self->do("sp_rename '$table.$tmpcol', '$column'") or return;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# An ALTER COLUMN in MS SQL cannot contain a default, so if a default is
|
||||
# specified that isn't the same as the old one, we drop the default
|
||||
# constraint and add a new one.
|
||||
my $new_default = delete $col{default};
|
||||
my $old_default = $old_col->{default};
|
||||
|
||||
my $default_changed = (
|
||||
defined $new_default and defined $old_default and $new_default ne $old_default
|
||||
or
|
||||
defined $new_default ne defined $old_default
|
||||
);
|
||||
|
||||
my @queries;
|
||||
|
||||
if ($default_changed) {
|
||||
if (defined $old_default) {
|
||||
push @queries, map "ALTER TABLE $table DROP CONSTRAINT $_", $self->_defaults($table, $column);
|
||||
}
|
||||
if (defined $new_default) {
|
||||
push @queries, "ALTER TABLE $table ADD CONSTRAINT default_${table}_$column DEFAULT " . $self->quote($new_default) . " FOR $column";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $new_default) {
|
||||
# Rewrite the column def without the DEFAULT (an ALTER COLUMN cannot contain a default in MSSQL)
|
||||
$new_def = $self->column_sql(\%col);
|
||||
}
|
||||
|
||||
push @queries, "ALTER TABLE $table ALTER COLUMN $column $new_def";
|
||||
|
||||
return @queries > 1
|
||||
? $self->do_raw_transaction(@queries)
|
||||
: $self->do($queries[0]);
|
||||
}
|
||||
|
||||
sub drop_index {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops an index. Versions of this module prior to 2.0 were quite broken -
|
||||
# first, the index naming was (database prefix)(index name) in some places, and
|
||||
# (prefixed table name)(index name) in others. Furthermore, no prefixing of
|
||||
# indexes is needed at all as, like MySQL, indexes are per-table. As such,
|
||||
# this driver now looks for all three types of index when attempting to remove
|
||||
# existing indexes.
|
||||
#
|
||||
my ($self, $table, $index_name) = @_;
|
||||
|
||||
return $self->do("DROP INDEX $table.$index_name")
|
||||
or $self->do("DROP INDEX $table.$table$index_name")
|
||||
or $self->do("DROP INDEX $table.$self->{connect}->{PREFIX}$index_name");
|
||||
}
|
||||
|
||||
sub extract_index_name {
|
||||
# -----------------------------------------------------------------------------
|
||||
my ($self, $table, $index) = @_;
|
||||
$index =~ s/^\Q$table\E(?=.)//i # broken (tablename)(index name) format
|
||||
or $index =~ s/^\Q$self->{connect}->{PREFIX}\E(?=.)//i; # broken (prefix)(index name) format;
|
||||
$index;
|
||||
}
|
||||
|
||||
|
||||
package GT::SQL::Driver::MSSQL::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
|
||||
use GT::SQL::Driver::sth;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{_insert_id} if $self->{_insert_id};
|
||||
|
||||
my $sth = $self->{dbh}->prepare('SELECT @@IDENTITY') or return $self->fatal(CANTPREPARE => 'SELECT @@IDENTITY', $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => 'SELECT @@IDENTITY', $DBI::errstr);
|
||||
$self->{_insert_id} = $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
# -------------------------------------------------------------------
|
||||
# Fetch off only rows we are interested in.
|
||||
#
|
||||
my $self = shift;
|
||||
if ($self->{_need_preparing}) {
|
||||
$self->{sth} = $self->{dbh}->prepare($self->{query}) or return $self->warn(CANTPREPARE => $self->{query}, $DBI::errstr);
|
||||
}
|
||||
if (my $binds = $GT::SQL::Driver::MSSQL::BINDS{$self->{query}}) {
|
||||
for my $bind (@$binds) {
|
||||
my ($index, $col, $type) = @$bind;
|
||||
$self->{sth}->bind_param($index, $_[$index-1], $type);
|
||||
}
|
||||
}
|
||||
else {
|
||||
# We need to look for any values longer than 8000 characters and bind_param them
|
||||
# to SQL_LONGVARCHAR's to avoid an implicit rebinding that results in a
|
||||
# "Can't rebind placeholder x" error.
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (defined $_[$i] and length $_[$i] > 8000) {
|
||||
$self->{sth}->bind_param($i+1, $_[$i], DBI::SQL_LONGVARCHAR);
|
||||
}
|
||||
}
|
||||
}
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
|
||||
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
$self->{_names} = $self->{_results} = $self->{_insert_id} = undef;
|
||||
|
||||
# Attempting to access ->{NAME} is not allowed for queries that don't actually
|
||||
# returning anything (such as 'ALTER TABLE foo ADD COLUMN a INT'); as such, try
|
||||
# to avoid them here. The eval is there just in case a query runs that isn't
|
||||
# caught.
|
||||
unless ($self->{do} =~ /^(?:ALTER|CREATE|INSERT|UPDATE|DROP|DELETE|SP_RENAME)$/) {
|
||||
eval {
|
||||
$self->{_names} = $self->{sth}->{NAME};
|
||||
};
|
||||
}
|
||||
|
||||
# Limit the results if needed.
|
||||
if ($self->{do} eq 'SELECT' or $self->{do} eq 'DESCRIBE') {
|
||||
my $none;
|
||||
if ($self->{_limit}) {
|
||||
my $begin = $self->{_lim_offset} || 0;
|
||||
for (1 .. $begin) {
|
||||
# Discard any leading rows that we don't care about
|
||||
$self->{sth}->fetchrow_arrayref or $none = 1, last;
|
||||
}
|
||||
}
|
||||
$self->{_results} = $none ? [] : $self->{sth}->fetchall_arrayref;
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{query} =~ /^\s*sp_/) {
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
else {
|
||||
$self->{rows} = $self->{sth}->rows;
|
||||
}
|
||||
$self->{sth}->finish;
|
||||
$self->{_need_preparing} = 1;
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
return $rc;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
# DATA TYPE MAPPINGS
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
package GT::SQL::Driver::MSSQL::Types;
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# MSSQL has a TINYINT type, however it is always unsigned, so only use it if
|
||||
# the column is _meant_ to be unsigned - otherwise use SMALLINT, which is
|
||||
# always signed.
|
||||
sub TINYINT {
|
||||
my ($class, $args) = @_;
|
||||
my $type = $args->{unsigned} ? 'TINYINT' : 'SMALLINT';
|
||||
$class->base($args, $type);
|
||||
}
|
||||
|
||||
# Though MSSQL supports a CHAR type, it can't be used because it doesn't trim
|
||||
# trailing spaces, and that would most likely break things designed to work
|
||||
# with the way 'CHAR's currently work.
|
||||
|
||||
sub DATE { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIME { croak "MSSQL does not support 'TIME' columns" }
|
||||
sub YEAR { $_[0]->base($_[1], 'DATETIME') }
|
||||
|
||||
# MSSQL doesn't support BLOB's, but has binary 'IMAGE' and 'VARBINARY' types -
|
||||
# the one (rather large) caveat to these being that they require escaping and
|
||||
# unescaping of input and output.
|
||||
|
||||
1;
|
||||
226
site/glist/lib/GT/SQL/Driver/MYSQL.pm
Normal file
226
site/glist/lib/GT/SQL/Driver/MYSQL.pm
Normal file
@ -0,0 +1,226 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MYSQL
|
||||
# CVS Info :
|
||||
# $Id: MYSQL.pm,v 2.1 2005/04/14 00:56:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: MySQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::MYSQL;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver;
|
||||
use DBD::mysql 1.19_03;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub dsn {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Creates the data source name used by DBI to connect to the database.
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
my $dsn;
|
||||
|
||||
$connect->{driver} ||= 'mysql';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
$dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= join ';', map { $connect->{$_} ? "$_=$connect->{$_}" : () } qw/database host port/;
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Prepares a query; rewrites PG-style LIMIT x OFFSET y into MySQL's confusing
|
||||
# LIMIT y, n
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/LIMIT $2, $1/i
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/LIMIT $1, $2/i;
|
||||
$query;
|
||||
}
|
||||
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs a multiple-insertion. We have to watch the maximum query length,
|
||||
# performing multiple queries if necessary.
|
||||
#
|
||||
my ($self, $cols, $args) = @_;
|
||||
|
||||
my $has_ai;
|
||||
$has_ai = grep $_ eq $self->{schema}->{ai}, @$cols if $self->{schema}->{ai};
|
||||
|
||||
my $names = join ",", @$cols;
|
||||
$names .= ",$self->{schema}->{ai}" if $self->{schema}->{ai} and not $has_ai;
|
||||
|
||||
my $ret;
|
||||
my $values = '';
|
||||
for (@$args) {
|
||||
my $new_val;
|
||||
$new_val = "(" . join(",", map GT::SQL::Driver::quote($_), @$_);
|
||||
$new_val .= ",NULL" if $self->{schema}->{ai} and not $has_ai;
|
||||
$new_val .= ")";
|
||||
|
||||
if ($values and length($values) + length($new_val) > 1_000_000) {
|
||||
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
|
||||
$values = '';
|
||||
}
|
||||
$values .= "," if $values;
|
||||
$values .= $new_val;
|
||||
}
|
||||
if ($values) {
|
||||
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
# If making a nullable TEXT column not null, make sure we update existing NULL
|
||||
# columns to get the default value.
|
||||
sub alter_column {
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
if ($col{type} =~ /TEXT$/i
|
||||
and $col{not_null}
|
||||
and not $old_col->{not_null}
|
||||
and defined $col{default}
|
||||
and not defined $old_col->{default}) {
|
||||
$self->{dbh}->do("UPDATE $table SET $column = ? WHERE $column IS NULL", undef, $col{default});
|
||||
}
|
||||
return $self->SUPER::alter_column(@_[1 .. $#_])
|
||||
}
|
||||
|
||||
sub create_index {
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD INDEX $index_name (" . join(',', @index_cols) . ")");
|
||||
}
|
||||
|
||||
sub create_unique {
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD UNIQUE $index_name (" . join(',', @index_cols) . ")");
|
||||
}
|
||||
|
||||
sub drop_index {
|
||||
my ($self, $table, $index_name) = @_;
|
||||
$self->do("ALTER TABLE $table DROP INDEX $index_name");
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::MYSQL::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver::sth;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Catch mysql's auto increment field.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{sth}->{mysql_insertid} || $self->{sth}->{insertid};
|
||||
}
|
||||
|
||||
sub rows { shift->{sth}->rows }
|
||||
|
||||
sub _execute_show_index {
|
||||
my $self = shift;
|
||||
$self->{sth}->execute or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
|
||||
my @results;
|
||||
|
||||
# Mysql columns are: Table Non_unique Key_name Seq_in_index Column_name Collation Cardinality Sub_part Packed Null Index_type Comment
|
||||
my @names = @{$self->row_names};
|
||||
# We need to add index_name, index_column, index_unique, index_primary (see GT::SQL::Driver)
|
||||
push @names, qw/index_name index_column index_unique index_primary/ unless $self->{_names};
|
||||
while (my $row = $self->{sth}->fetchrow_arrayref) {
|
||||
my %h = map { $names[$_] => $row->[$_] } 0 .. $#$row;
|
||||
push @results, [@$row, $h{Key_name}, $h{Column_name}, $h{Non_unique} ? 0 : 1, $h{Key_name} eq 'PRIMARY' ? 1 : 0];
|
||||
}
|
||||
|
||||
$self->{rows} = @results;
|
||||
$self->{_names} = \@names;
|
||||
$self->{_results} = \@results;
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::MYSQL::Types;
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# Integers. MySQL supports non-standard unsigned and zerofill properties;
|
||||
# unsigned, though unportable, is supported here, however zerofill - whose
|
||||
# usefulness is dubious at best - is not.
|
||||
sub TINYINT { $_[0]->base($_[1], 'TINYINT', ['unsigned']) }
|
||||
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT', ['unsigned']) }
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'MEDIUMINT', ['unsigned']) }
|
||||
sub INT { $_[0]->base($_[1], 'INT', ['unsigned']) }
|
||||
sub BIGINT { $_[0]->base($_[1], 'BIGINT', ['unsigned']) }
|
||||
|
||||
# Floats - MySQL's 'REAL' is really a 64-bit floating point number, while for
|
||||
# everything else 'REAL' is a 32-bit floating point number, so we override the
|
||||
# defaults here to FLOAT.
|
||||
sub FLOAT { $_[0]->base($_[1], 'FLOAT') }
|
||||
sub REAL { $_[0]->base($_[1], 'FLOAT') }
|
||||
|
||||
sub CHAR {
|
||||
my ($class, $args, $out) = @_;
|
||||
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
|
||||
|
||||
$out ||= 'CHAR';
|
||||
$out .= "($args->{size})";
|
||||
$out .= ' BINARY' if $args->{binary}; # MySQL-only
|
||||
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub TEXT {
|
||||
my ($class, $args) = @_;
|
||||
my $type = 'LONGTEXT';
|
||||
delete $args->{default}; # MySQL is the only driver that doesn't support defaults on TEXT's
|
||||
if ($args->{size}) {
|
||||
if ($args->{size} < 256) {
|
||||
$type = 'TINYTEXT';
|
||||
}
|
||||
elsif ($args->{size} < 65536) {
|
||||
$type = 'TEXT';
|
||||
}
|
||||
elsif ($args->{size} < 16777216) {
|
||||
$type = 'MEDIUMTEXT';
|
||||
}
|
||||
}
|
||||
|
||||
$class->base($args, $type);
|
||||
}
|
||||
|
||||
# MySQL supports ENUM; the generic ENUM is mapped to a VARCHAR
|
||||
sub ENUM {
|
||||
my ($class, $args) = @_;
|
||||
@{$args->{'values'}} or return;
|
||||
my $out = 'ENUM(' . join(",", map GT::SQL::Driver->quote($_), @{$args->{values}}) . ')';
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
$out;
|
||||
}
|
||||
|
||||
sub BLOB {
|
||||
my ($class, $attrib, $blob) = @_;
|
||||
delete $attrib->{default};
|
||||
$class->base($attrib, $blob || 'BLOB');
|
||||
}
|
||||
|
||||
1;
|
||||
541
site/glist/lib/GT/SQL/Driver/ORACLE.pm
Normal file
541
site/glist/lib/GT/SQL/Driver/ORACLE.pm
Normal file
@ -0,0 +1,541 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::ORACLE
|
||||
# CVS Info :
|
||||
# $Id: ORACLE.pm,v 2.1 2005/02/01 02:01:18 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Oracle 8+ driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::ORACLE;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $ERRORS %BINDS/;
|
||||
|
||||
use DBD::Oracle qw/:ora_types/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub connect {
|
||||
# ------------------------------------------------------------------
|
||||
# Need to set some session preferences.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# ORACLE_HOME must be set for the DBD::Oracle driver to function properly.
|
||||
return $self->warn('NOORACLEHOME') unless exists $ENV{ORACLE_HOME};
|
||||
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# Set the date format to same format as other drivers use.
|
||||
$dbh->do("ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'")
|
||||
or return $self->fatal(NONLSDATE => $DBI::errstr);
|
||||
|
||||
# Set max read properties for DBI.
|
||||
$dbh->{LongReadLen} = 1_048_576;
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Oracle DSN looks like:
|
||||
# DBI:Oracle:host=HOST;port=POST;sid=SID
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$connect->{driver} ||= 'Oracle';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
my $dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= "host=$connect->{host}";
|
||||
$dsn .= ";port=$connect->{port}" if $connect->{port};
|
||||
$dsn .= ";sid=$connect->{database}";
|
||||
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub hints {
|
||||
case_map => 1,
|
||||
prefix_indexes => 1,
|
||||
bind => [
|
||||
\%BINDS,
|
||||
'TEXT' => ORA_CLOB,
|
||||
'BLOB' => ORA_BLOB
|
||||
],
|
||||
now => 'SYSDATE',
|
||||
ai => sub {
|
||||
my ($table, $column) = @_;
|
||||
my $seq = "${table}_seq";
|
||||
my @q;
|
||||
push @q, \"DROP SEQUENCE $seq";
|
||||
push @q, "CREATE SEQUENCE $seq INCREMENT BY 1 START WITH 1 NOCYCLE";
|
||||
\@q;
|
||||
}
|
||||
}
|
||||
|
||||
sub prepare {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Clear our limit counters. Oracle does not have built-in limit support, so it
|
||||
# is handled here by fetching all the results that were asked for into _results
|
||||
# and our own fetchrow methods work off that.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
# Oracle uses "SUBSTR" instead of "SUBSTRING"
|
||||
$query =~ s/\bSUBSTRING\(/SUBSTR(/gi;
|
||||
|
||||
$self->SUPER::prepare($query);
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Need to store what the requested result set; no built in LIMIT support like
|
||||
# mysql.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
my ($limit, $offset);
|
||||
|
||||
# Handle either PG or MySQL limits
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
|
||||
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
|
||||
|
||||
if ($limit) {
|
||||
$self->{_limit} = 1;
|
||||
$self->{_lim_rows} = $limit;
|
||||
$self->{_lim_offset} = $offset;
|
||||
}
|
||||
|
||||
# LEFT OUTER JOIN is not supported, instead:
|
||||
# ... FROM Table1, Table2 WHERE col1 = col2(+) ...
|
||||
$query =~ s{FROM\s+(\w+)\s+LEFT OUTER JOIN\s+(\w+)\s+ON\s+([\w.]+)\s*=\s*([\w.]+)(\s+WHERE\s+)?}{
|
||||
my ($table1, $table2, $col1, $col2, $where) = ($1, $2, $3, $4, $5);
|
||||
my $from_where = "FROM $table1, $table2 WHERE ";
|
||||
$from_where .= index($col1, "$table1.") == 0
|
||||
? "$col1 = $col2(+)"
|
||||
: "$col2 = $col1(+)";
|
||||
$from_where .= " AND " if $where;
|
||||
$from_where;
|
||||
}ie;
|
||||
|
||||
$query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# ------------------------------------------------------------------
|
||||
# Oracle supports USER_TAB_COLUMNS to get information
|
||||
# about a table.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /DESCRIBE\s+(\w+)/i) {
|
||||
return <<" QUERY";
|
||||
SELECT COLUMN_NAME, DATA_TYPE, DATA_LENGTH, DATA_PRECISION, DATA_SCALE, NULLABLE, DATA_DEFAULT
|
||||
FROM USER_TAB_COLUMNS
|
||||
WHERE TABLE_NAME = '\U$1\E'
|
||||
ORDER BY COLUMN_ID
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Cannot get properties from db_tab_columns");
|
||||
}
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT COUNT(*)
|
||||
FROM USER_TAB_COLUMNS
|
||||
WHERE TABLE_NAME = ? AND COLUMN_NAME = ?
|
||||
EXISTS
|
||||
$sth->execute(uc $table, uc $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Oracle's equivelant to SHOW TABLES
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{do} = 'SELECT';
|
||||
'SELECT table_name FROM USER_TABLES ORDER BY table_name';
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Get an index list; see 'Driver-specific notes' comment in GT::SQL::Driver
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
# The below isn't quite perfect - Oracle 8 doesn't support CASE (9 does), so
|
||||
# the 'index_unique' still has to be mapped to a 1/0 value in execute(). Also
|
||||
# worth noting is that primary keys in Oracle don't always get their own index
|
||||
# - in particular, when adding a primary key to a table using a column that is
|
||||
# already indexed, the primary key will simply use the existing index instead
|
||||
# of creating a new one.
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
ic.index_name AS "index_name",
|
||||
ic.column_name AS "index_column",
|
||||
(
|
||||
SELECT COUNT(*) FROM user_constraints c, user_cons_columns cc
|
||||
WHERE c.index_name = i.index_name AND c.constraint_name = cc.constraint_name
|
||||
AND c.constraint_type = 'P' AND cc.column_name = ic.column_name
|
||||
) "index_primary",
|
||||
uniqueness AS "index_unique"
|
||||
FROM
|
||||
user_ind_columns ic,
|
||||
user_indexes i
|
||||
WHERE
|
||||
ic.index_name = i.index_name AND
|
||||
LOWER(ic.table_name) = '\L$1\E'
|
||||
ORDER BY
|
||||
ic.index_name,
|
||||
ic.column_position
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
|
||||
}
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a table, including a sequence if necessary
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $seq = uc "${table}_seq";
|
||||
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '$seq'");
|
||||
$sth->execute();
|
||||
if (my $seq_name = $sth->fetchrow) {
|
||||
my $sth = $self->{dbh}->prepare("DROP SEQUENCE $seq");
|
||||
$sth->execute or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq", $GT::SQL::error);
|
||||
}
|
||||
return $self->SUPER::drop_table($table);
|
||||
}
|
||||
|
||||
sub ai_insert {
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, "$self->{name}_seq.NEXTVAL";
|
||||
}
|
||||
|
||||
sub alter_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Changes a column. Takes table name, column name, and new column definition.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
# make a copy so the original reference doesn't get clobbered
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
# If the default value was removed, then make sure that the default constraint
|
||||
# from the previous instance is deactivated.
|
||||
if (not exists $col{default} and defined $old_col->{default} and length $old_col->{default}) {
|
||||
$col{default} = \'NULL';
|
||||
}
|
||||
|
||||
# Oracle doesn't like being told to make an already NOT NULL column NOT NULL:
|
||||
if ($col{not_null} and $old_col->{not_null}) {
|
||||
delete $col{not_null};
|
||||
}
|
||||
|
||||
$new_def = $self->column_sql(\%col);
|
||||
|
||||
# But it needs an explicit NULL to drop the field's NOT NULL
|
||||
if (not $col{not_null} and $old_col->{not_null}) {
|
||||
$new_def .= ' NULL';
|
||||
}
|
||||
|
||||
# Oracle doesn't need the data type, and won't accept it on CLOB/BLOB columns
|
||||
$new_def =~ s/^[BC]LOB ?//;
|
||||
$new_def or return 1; # If the def is empty now, there really isn't anything to be done.
|
||||
|
||||
$self->do("ALTER TABLE $table MODIFY $column $new_def");
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
$self->do("ALTER TABLE $table DROP COLUMN $column");
|
||||
}
|
||||
|
||||
sub create_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a primary key to a table.
|
||||
#
|
||||
my ($self, $table, @cols) = @_;
|
||||
$self->create_index($table, "${table}_pkey", @cols);
|
||||
$self->do("ALTER TABLE $table ADD CONSTRAINT ${table}_pkey PRIMARY KEY (" . join(",", @cols) . ")");
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::ORACLE::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
|
||||
use GT::SQL::Driver::sth;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{_insert_id} if $self->{_insert_id};
|
||||
|
||||
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
|
||||
$table ||= $self->{name};
|
||||
my $seq = $table . "_seq.CURRVAL";
|
||||
my $query = "SELECT $seq FROM $table";
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query, $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => $query, $DBI::errstr);
|
||||
my ($id) = $sth->fetchrow_array;
|
||||
$self->{_insert_id} = $id;
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
# -------------------------------------------------------------------
|
||||
# Fetch off only desired rows.
|
||||
#
|
||||
my $self = shift;
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
if ($GT::SQL::Driver::ORACLE::BINDS{$self->{query}}) {
|
||||
for my $bind (@{$GT::SQL::Driver::ORACLE::BINDS{$self->{query}}}) {
|
||||
my ($index, $col, $type) = @$bind;
|
||||
$self->{sth}->bind_param($index, $_[$index - 1], { ora_type => $type, ora_field => $col });
|
||||
}
|
||||
}
|
||||
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
$self->{_results} = [];
|
||||
$self->{_insert_id} = '';
|
||||
$self->{_names} = $self->{sth}->{NAME};
|
||||
if ($self->{do} eq 'SELECT') {
|
||||
$self->{_lim_cnt} = 0;
|
||||
if ($self->{_limit}) {
|
||||
my $begin = $self->{_lim_offset} || 0;
|
||||
my $end = $begin + $self->{_lim_rows};
|
||||
my $i = -1;
|
||||
while (my $rec = $self->{sth}->fetchrow_arrayref) {
|
||||
$i++;
|
||||
next if $i < $begin;
|
||||
last if $i >= $end;
|
||||
push @{$self->{_results}}, [@$rec]; # Must copy as ref is reused in DBI.
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
}
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{do} eq 'SHOW INDEX') {
|
||||
$self->{_names} = $self->{sth}->{NAME_lc};
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
my $i = 0;
|
||||
for (@{$self->{_names}}) { last if $_ eq 'index_unique'; $i++ }
|
||||
for (@{$self->{_results}}) {
|
||||
$_->[$i] = uc($_->[$i]) eq 'UNIQUE' ? 1 : 0;
|
||||
}
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{do} eq 'DESCRIBE') {
|
||||
$rc = $self->_fixup_describe();
|
||||
}
|
||||
else {
|
||||
$self->{rows} = $self->{sth}->rows;
|
||||
}
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
return $rc;
|
||||
}
|
||||
|
||||
sub _fixup_describe {
|
||||
# ---------------------------------------------------------------
|
||||
# Converts output of 'sp_columns tablename' into similiar results
|
||||
# of mysql's describe tablename.
|
||||
#
|
||||
my $self = shift;
|
||||
my @results;
|
||||
|
||||
# Mysql Cols are: Field, Type, Null, Key, Default, Extra
|
||||
my $table = uc $self->{name};
|
||||
while (my $col = $self->{sth}->fetchrow_hashref) {
|
||||
my ($table, $field, $type, $size, $prec, $scale) = @$col{qw/TABLE_NAME COLUMN_NAME DATA_TYPE DATA_LENGTH DATA_PRECISION DATA_SCALE/};
|
||||
my $null = $col->{NULLABLE} eq 'Y';
|
||||
my $default = (not defined $col->{DATA_DEFAULT} or $col->{DATA_DEFAULT} =~ /^''\s*/) ? '' : $col->{DATA_DEFAULT};
|
||||
|
||||
$size = length $default if length $default > $size;
|
||||
|
||||
if ($type =~ /VARCHAR2|CHAR/) {
|
||||
$type = "varchar($size)";
|
||||
}
|
||||
elsif ($type =~ /NUMBER/ and !$scale) {
|
||||
if ($prec) {
|
||||
$type =
|
||||
$prec >= 11 ? 'bigint' :
|
||||
$prec >= 9 ? 'int' :
|
||||
$prec >= 6 ? 'mediumint' :
|
||||
$prec >= 4 ? 'smallint' :
|
||||
'tinyint';
|
||||
}
|
||||
else {
|
||||
$type = 'bigint';
|
||||
}
|
||||
}
|
||||
elsif ($type =~ /NUMBER/ and length $prec and length $scale) {
|
||||
$type = "decimal($prec, $scale)";
|
||||
}
|
||||
elsif ($type =~ /FLOAT/) {
|
||||
$type = (!$prec or $prec > 23) ? 'double' : 'real';
|
||||
}
|
||||
elsif ($type =~ /LONG|CLOB|NCLOB/) {
|
||||
$type = 'text';
|
||||
}
|
||||
elsif ($type =~ /DATE/) {
|
||||
$type = 'datetime';
|
||||
}
|
||||
|
||||
$type = lc $type;
|
||||
$default =~ s,^NULL\s*,,;
|
||||
$default =~ s,^\(?'(.*)'\)?\s*$,$1,;
|
||||
$null = $null ? 'YES' : '';
|
||||
push @results, [$field, $type, $null, '', $default, ''];
|
||||
}
|
||||
( $#results < 0 ) and return;
|
||||
|
||||
# Fetch the Primary key
|
||||
my $que_pk = <<" QUERY";
|
||||
SELECT COL.COLUMN_NAME
|
||||
FROM USER_CONS_COLUMNS COL, USER_CONSTRAINTS CON
|
||||
WHERE COL.TABLE_NAME = '\U$table\E'
|
||||
AND COL.TABLE_NAME = CON.TABLE_NAME
|
||||
AND COL.CONSTRAINT_NAME = CON.CONSTRAINT_NAME
|
||||
AND CON.CONSTRAINT_TYPE='P'
|
||||
QUERY
|
||||
my $sth_pk = $self->{dbh}->prepare($que_pk);
|
||||
$sth_pk->execute;
|
||||
my $indexes = {};
|
||||
while ( my $col = $sth_pk->fetchrow_array ) {
|
||||
$indexes->{$col} = "PRI";
|
||||
}
|
||||
$sth_pk->finish;
|
||||
|
||||
# Fetch the index information.
|
||||
my $que_idx = <<" QUERY";
|
||||
SELECT *
|
||||
FROM USER_INDEXES IND, USER_IND_COLUMNS COL
|
||||
WHERE IND.TABLE_NAME = '\U$table\E'
|
||||
AND IND.TABLE_NAME = COL.TABLE_NAME
|
||||
AND IND.INDEX_NAME = COL.INDEX_NAME
|
||||
QUERY
|
||||
|
||||
my $sth_idx = $self->{dbh}->prepare($que_idx);
|
||||
$sth_idx->execute;
|
||||
while ( my $col = $sth_idx->fetchrow_hashref ) {
|
||||
my $key = $col->{UNIQUENESS} =~ /UNIQUE/ ? 'UNIQUE' : 'MUL';
|
||||
exists $indexes->{$col->{COLUMN_NAME}} or $indexes->{$col->{COLUMN_NAME}} = $key;
|
||||
}
|
||||
|
||||
for my $result (@results) {
|
||||
if (defined $indexes->{$result->[0]}) {
|
||||
$result->[3] = $indexes->{$result->[0]};
|
||||
if ($result->[1] =~ /int/) { # Set extra
|
||||
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '\U$table\E_SEQ'");
|
||||
$sth->execute;
|
||||
$result->[5] = 'auto_increment' if $sth->fetchrow;
|
||||
$sth->finish;
|
||||
}
|
||||
}
|
||||
}
|
||||
$sth_idx->finish;
|
||||
$self->{_results} = \@results;
|
||||
$self->{_names} = [qw/Field Type Null Key Default Extra/];
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub finish {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
delete $GT::SQL::Driver::ORACLE::BINDS{$self->{query}};
|
||||
$self->SUPER::finish;
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# DATA TYPE MAPPINGS
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
package GT::SQL::Driver::ORACLE::Types;
|
||||
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# Quoting table and/or column names gives case-sensitivity to the table and
|
||||
# column names in Oracle - however, because this needs to be compatible with
|
||||
# older versions of this driver that didn't properly handle table/column case,
|
||||
# we can't use that to our advantage, as all the old unquoted tables/columns
|
||||
# would be upper-case - TABLE or COLUMN will be the name in the database, and
|
||||
# "Table" or "column" would not exist. It would, however, still be nice to
|
||||
# support this at some point:
|
||||
# sub base {
|
||||
# my ($class, $args, $name, $attribs) = @_;
|
||||
# $class->SUPER::base($args, qq{"$name"}, $attribs);
|
||||
# }
|
||||
|
||||
sub TINYINT { $_[0]->base($_[1], 'NUMBER(3)') }
|
||||
sub SMALLINT { $_[0]->base($_[1], 'NUMBER(5)') }
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'NUMBER(8)') }
|
||||
sub INT { $_[0]->base($_[1], 'NUMBER(10)') }
|
||||
sub BIGINT { $_[0]->base($_[1], 'NUMBER(19)') }
|
||||
sub REAL { $_[0]->base($_[1], 'FLOAT(23)') }
|
||||
sub DOUBLE { $_[0]->base($_[1], 'FLOAT(52)') }
|
||||
|
||||
sub DATETIME { $_[0]->base($_[1], 'DATE') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'DATE') }
|
||||
sub TIME { croak "Oracle does not support 'TIME' columns\n" }
|
||||
sub YEAR { croak "Oracle does not support 'YEAR' columns\n" }
|
||||
|
||||
sub CHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
|
||||
sub VARCHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
|
||||
sub TEXT { $_[0]->base($_[1], 'CLOB') }
|
||||
sub BLOB { delete $_[1]->{default}; $_[0]->base($_[1], 'BLOB') }
|
||||
|
||||
1;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user